perm filename LISP.248[MAC,LSP] blob
sn#251574 filedate 1976-12-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00653 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00016 00002
C00020 00003
C00024 00004
C00026 00005
C00030 00006
C00034 00007
C00036 00008
C00038 00009
C00041 00010
C00045 00011
C00047 00012
C00052 00013
C00056 00014
C00065 00015
C00067 00016 @ END OF DEFNS 83
C00069 00017
C00071 00018
C00073 00019
C00075 00020
C00077 00021
C00079 00022
C00082 00023
C00084 00024
C00086 00025
C00090 00026
C00094 00027
C00098 00028 @ END OF MACS 45
C00099 00029
C00100 00030
C00103 00031
C00106 00032
C00108 00033
C00111 00034
C00113 00035
C00115 00036
C00117 00037
C00120 00038
C00122 00039
C00124 00040
C00127 00041
C00129 00042
C00131 00043
C00134 00044
C00138 00045
C00141 00046
C00144 00047
C00148 00048
C00151 00049
C00154 00050
C00158 00051
C00161 00052
C00164 00053
C00166 00054
C00170 00055
C00172 00056
C00175 00057
C00178 00058
C00183 00059
C00187 00060
C00189 00061
C00191 00062
C00194 00063
C00198 00064
C00201 00065
C00205 00066
C00208 00067
C00211 00068
C00213 00069
C00216 00070
C00218 00071
C00220 00072
C00222 00073
C00226 00074
C00228 00075
C00230 00076
C00232 00077
C00234 00078
C00236 00079
C00239 00080
C00241 00081
C00245 00082
C00247 00083
C00250 00084
C00253 00085
C00255 00086
C00258 00087
C00260 00088 @ END OF ERROR 43
C00262 00089
C00266 00090
C00269 00091
C00271 00092
C00274 00093
C00277 00094
C00279 00095
C00281 00096
C00283 00097
C00285 00098
C00288 00099
C00292 00100
C00293 00101
C00295 00102
C00297 00103
C00299 00104
C00301 00105
C00303 00106
C00306 00107
C00308 00108
C00309 00109
C00312 00110
C00315 00111
C00318 00112
C00320 00113
C00325 00114
C00327 00115
C00329 00116
C00331 00117
C00333 00118
C00336 00119
C00338 00120
C00340 00121
C00342 00122
C00343 00123
C00345 00124
C00347 00125
C00349 00126
C00352 00127
C00354 00128
C00356 00129
C00358 00130
C00360 00131
C00361 00132
C00363 00133
C00366 00134
C00367 00135
C00369 00136
C00371 00137
C00373 00138
C00377 00139
C00381 00140
C00383 00141
C00387 00142
C00389 00143
C00390 00144
C00392 00145
C00394 00146
C00396 00147
C00399 00148
C00401 00149
C00403 00150
C00407 00151
C00409 00152
C00414 00153
C00417 00154
C00420 00155
C00422 00156
C00424 00157
C00427 00158
C00429 00159
C00433 00160
C00434 00161
C00436 00162
C00439 00163
C00442 00164
C00444 00165
C00446 00166
C00452 00167
C00454 00168
C00457 00169
C00459 00170
C00461 00171
C00462 00172
C00465 00173
C00469 00174
C00472 00175
C00475 00176
C00478 00177
C00482 00178
C00484 00179
C00486 00180
C00488 00181
C00490 00182
C00492 00183
C00494 00184
C00496 00185
C00498 00186
C00501 00187
C00502 00188
C00505 00189
C00508 00190
C00511 00191
C00513 00192
C00515 00193
C00517 00194
C00520 00195
C00523 00196
C00525 00197
C00527 00198
C00529 00199
C00530 00200
C00533 00201
C00536 00202
C00539 00203 @ END OF STATUS 93
C00540 00204
C00543 00205
C00548 00206
C00550 00207
C00555 00208
C00558 00209
C00561 00210
C00563 00211
C00565 00212
C00566 00213
C00570 00214
C00572 00215
C00573 00216
C00576 00217
C00579 00218
C00581 00219
C00585 00220
C00587 00221
C00590 00222
C00594 00223
C00598 00224
C00600 00225
C00602 00226
C00605 00227
C00607 00228
C00609 00229
C00612 00230 TEST CURRENT LOCATION
C00614 00231
C00616 00232 @ END OF EDITOR 14
C00617 00233
C00620 00234
C00624 00235
C00627 00236
C00629 00237
C00631 00238
C00633 00239
C00636 00240
C00639 00241
C00641 00242
C00643 00243
C00646 00244
C00648 00245
C00650 00246
C00652 00247
C00653 00248
C00655 00249
C00657 00250
C00659 00251
C00661 00252
C00663 00253
C00665 00254
C00667 00255
C00669 00256
C00671 00257 @ END OF MOBYIO 13
C00673 00258
C00675 00259
C00677 00260
C00679 00261
C00682 00262
C00685 00263
C00688 00264
C00692 00265
C00695 00266
C00698 00267
C00700 00268
C00702 00269
C00707 00270
C00710 00271
C00715 00272
C00717 00273
C00720 00274
C00722 00275
C00725 00276
C00727 00277
C00729 00278
C00732 00279
C00735 00280
C00738 00281
C00740 00282
C00741 00283
C00743 00284
C00745 00285
C00748 00286
C00749 00287
C00752 00288
C00755 00289
C00758 00290
C00759 00291 @ END OF PRINT 113
C00761 00292
C00764 00293
C00766 00294
C00768 00295
C00771 00296
C00775 00297
C00778 00298
C00780 00299
C00782 00300
C00785 00301
C00787 00302
C00788 00303
C00790 00304
C00793 00305
C00795 00306
C00797 00307
C00802 00308
C00803 00309
C00806 00310
C00808 00311
C00810 00312
C00812 00313
C00814 00314
C00815 00315
C00818 00316 @ END OF ULAP 80
C00819 00317
C00821 00318
C00823 00319
C00826 00320
C00828 00321
C00830 00322
C00832 00323
C00833 00324
C00834 00325
C00835 00326
C00837 00327
C00839 00328
C00841 00329
C00844 00330
C00846 00331
C00849 00332
C00851 00333
C00854 00334
C00857 00335
C00858 00336
C00860 00337
C00863 00338
C00865 00339
C00867 00340
C00869 00341
C00873 00342
C00874 00343
C00876 00344
C00879 00345
C00882 00346
C00883 00347
C00884 00348 @ END OF ARITH 47
C00886 00349
C00888 00350
C00890 00351
C00892 00352
C00894 00353
C00896 00354
C00898 00355
C00901 00356
C00904 00357
C00906 00358
C00908 00359
C00910 00360
C00912 00361
C00914 00362
C00915 00363
C00918 00364
C00920 00365
C00922 00366
C00924 00367
C00926 00368
C00929 00369
C00933 00370
C00935 00371 @ END OF BIGNUM 12
C00936 00372
C00938 00373
C00941 00374
C00943 00375
C00945 00376
C00947 00377
C00948 00378
C00950 00379
C00951 00380
C00953 00381
C00956 00382
C00959 00383
C00960 00384
C00964 00385
C00966 00386
C00969 00387
C00971 00388
C00973 00389
C00975 00390
C00977 00391
C00979 00392
C00981 00393
C00983 00394
C00985 00395
C00987 00396
C00990 00397
C00993 00398
C00996 00399
C00999 00400
C01001 00401
C01003 00402
C01004 00403
C01009 00404
C01010 00405
C01013 00406
C01016 00407
C01020 00408
C01023 00409
C01026 00410
C01028 00411
C01033 00412
C01036 00413
C01038 00414
C01041 00415
C01043 00416
C01046 00417
C01049 00418
C01052 00419
C01054 00420
C01056 00421
C01059 00422
C01063 00423
C01067 00424
C01070 00425
C01072 00426
C01074 00427
C01076 00428
C01080 00429
C01084 00430
C01086 00431
C01088 00432
C01090 00433
C01092 00434
C01094 00435
C01096 00436
C01098 00437 @ END OF GCBIB 122
C01102 00438
C01105 00439
C01107 00440
C01108 00441
C01110 00442
C01114 00443
C01116 00444
C01118 00445
C01120 00446
C01128 00447
C01130 00448
C01132 00449
C01135 00450
C01137 00451
C01140 00452
C01142 00453
C01145 00454
C01147 00455
C01149 00456
C01150 00457
C01152 00458
C01154 00459
C01156 00460
C01158 00461
C01160 00462
C01162 00463
C01164 00464
C01166 00465
C01168 00466
C01169 00467
C01172 00468
C01175 00469
C01177 00470
C01179 00471
C01181 00472
C01184 00473
C01193 00474
C01197 00475
C01200 00476
C01202 00477
C01205 00478 @ END OF READER 92
C01207 00479
C01210 00480
C01212 00481
C01214 00482
C01216 00483
C01221 00484
C01222 00485
C01225 00486
C01227 00487
C01229 00488
C01231 00489
C01233 00490
C01235 00491
C01237 00492
C01240 00493
C01245 00494
C01249 00495
C01251 00496
C01252 00497
C01256 00498 @ END OF ARRAY 48
C01260 00499
C01261 00500
C01265 00501
C01268 00502
C01271 00503
C01275 00504
C01277 00505
C01280 00506
C01284 00507
C01287 00508
C01290 00509
C01292 00510
C01294 00511
C01295 00512
C01297 00513
C01299 00514
C01302 00515
C01304 00516
C01306 00517
C01308 00518
C01310 00519
C01311 00520
C01313 00521
C01315 00522
C01317 00523
C01320 00524 @ END OF FASLOA 89
C01325 00525
C01329 00526
C01335 00527
C01337 00528
C01340 00529
C01344 00530
C01346 00531
C01349 00532
C01351 00533
C01354 00534
C01357 00535
C01361 00536
C01364 00537
C01369 00538
C01394 00539
C01396 00540
C01398 00541
C01401 00542
C01403 00543
C01404 00544
C01407 00545
C01410 00546
C01413 00547
C01416 00548
C01418 00549
C01421 00550 @ END OF QIO 248
C01422 00551
C01424 00552
C01426 00553
C01429 00554
C01431 00555
C01434 00556
C01437 00557
C01440 00558
C01442 00559
C01446 00560
C01448 00561
C01450 00562
C01453 00563
C01455 00564
C01457 00565
C01459 00566
C01461 00567
C01463 00568
C01467 00569
C01470 00570
C01473 00571
C01476 00572
C01480 00573
C01484 00574
C01488 00575
C01490 00576
C01492 00577
C01495 00578
C01497 00579
C01499 00580
C01502 00581
C01504 00582
C01507 00583
C01510 00584
C01512 00585
C01515 00586
C01517 00587
C01519 00588
C01521 00589
C01523 00590
C01526 00591
C01528 00592
C01531 00593
C01534 00594
C01535 00595
C01537 00596
C01541 00597
C01543 00598
C01545 00599
C01547 00600
C01550 00601
C01552 00602
C01554 00603
C01557 00604
C01560 00605
C01562 00606
C01564 00607
C01568 00608
C01570 00609
C01573 00610
C01577 00611
C01579 00612
C01580 00613
C01584 00614
C01587 00615
C01589 00616
C01592 00617
C01594 00618
C01596 00619
C01598 00620
C01600 00621
C01603 00622
C01605 00623
C01608 00624
C01611 00625
C01613 00626
C01616 00627
C01617 00628
C01618 00629
C01619 00630 @ END OF STRUCT 204
C01622 00631
C01624 00632
C01627 00633
C01630 00634
C01632 00635
C01635 00636 IFN D10,[
C01636 00637
C01637 00638
C01640 00639
C01642 00640
C01643 00641
C01647 00642
C01650 00643
C01652 00644
C01659 00645
C01661 00646
C01663 00647
C01664 00648
C01666 00649
C01671 00650 ALLDONE: MOVEI A,LISP
C01672 00651
C01674 00652 @ END OF ALLOC 92
C01675 00653
C01676 ENDMK
C⊗;
;;; **************************************************************
;;; ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1976 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
IFE .OSMIDAS-<SIXBIT \ITS\>, .SYMTAB 16001. ;ENSURE ROOM FOR MANY SYMBOLS
.ELSE .SYMTAB 6560.
TITLE ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
.NSTGWD ;NO STORAGE WORDS PLEASE UNTIL FIRSTLOC
.XCREF A,B,C,AR1,AR2A,T,TT,D,R,F,P,FXP,%
.MLLIT==1
VERSION==.FNAM2 ;BY CONVENTION, THE SIXBIT FOR THE VERSION NUMBER
SUBTTL ASSEMBLY PARAMETERS
IF1,[ ;***** CONDITIONAL ASSEMBLY FLAGS AND PARAMETERS *****
;" FOR ASSLIS - DO NOT PUT ANY OTHER DOUBLE QUOTES ON THIS PAGE
ITS==1 ;FOR RUNNING UNDER THE ITS MONITOR
D10==0 ;FOR RUNNING UNDER DEC SYSTEM 10 MONITOR
SAIL==0 ;FOR RUNNING UNDER SAIL MONITOR
TENEX==0 ;FOR RUNNING UNDER THE TENEX MONITOR
ML==0 ;=1 SAYS THIS LISP IS FOR MATHLAB INSTEAD OF AI
;WHEN RUNNING UNDER THE ITS MONITOR
MOBIOF==0 ;DISPLAY SLAVE, VIDISSECTOR, A/D, D/A, AND PLOTTER ROUTINES FLAG
;WILL GO AWAY WHEN NEWIO MAKES IT FASLOADABLE
BIGNUM==1 ;MULTIPLE PRECISION ROUTINES FLAG
EDFLAG==1 ;ROUTINES FOR LISP EDITOR FLAG
;IF 0, CAUSES EDIT TO HAVE AN AUTOLOAD PROPERTY
OBTSIZ==777 ;LENGTH OF OBLIST
PTCSIZ==40 ;MINIMUM SIZE FOR PATCH AREA
FUNAFL==1 ;FUNARG, FAKE ALIST, AND LABEL STUFF
NEWRD==0 ;NEW READER FORMAT ETC
QIO==0 ;QUUX'S NEWIO STUFF
JOBQIO==1 ;SUPPORT FOR INFERIOR PROCEDURES
NSTAT==1 ;NEW STATUS FUNCTION
HNKLOG==4 ;LOG2 OF SIZE (IN WORDS) OF LARGEST HUNK (0 => NO HUNKS)
USELESS==1 ;NOT PARTICULARLY IMPORTANT FEATURES, LIKE:
; 1) ROMAN NUMERAL READER AND PRINTER
; 2) PRINLEVEL AND PRINLENGTH
; 3) IMPROVED FLOATING POINT PRINTOUT, AND DOUBLE-PRECISION INPUT
; 4) CURSORPOS
; 5) GCD
; 6) DUMPARRAYS, LOADARRAYS [AUTOLOADED IN NEWIO]
; 7) RECLAIM, AND RETSP FEATURE WHICH RETURNS BPS CORE TO TS SYSTEM
; 8) PURIFY, AND PURE-INITIAL-READ-TABLE
; 9) IN QIO, CLI INTERRUPT SUPPORT
; 10) IN QIO, MAR-BREAK SUPPORT
; 11) IN QIO, AUTOLOAD PROPERTIES FOR ALLFILES ETC.
; 13) CLEVER TERPRI-BEFORE-THE-PARENS HACK
SEGLOG==11 ;LOG2 OF # OF WORDS PER SEGMENT
;" FOR ASSLIS - DOUBLE QUOTES ARE OKAY NOW
;;; IF1
SUBTTL STORAGE LAYOUTS
;;; STORAGE LAYOUT FOR ITS
;;;
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSYSSG FIRSTL: INITIAL SYSTEM CODE (PURE)
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; C(BPSL) (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS
;;; ... BINARY PROGRAM SPACE GROWS UPWARD ...
;;; C(HINXM) LAST WORD OF GROSS HOLE IN MEMORY
;;; ... LIST STRUCTURE GROWS DOWNWARD ...
;;; PUSHDOWN LISTS WITH HOLES BETWEEN:
;;; FXP, FLP, P, SP
;;;
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;;
;;; STORAGE LAYOUT FOR DEC10
;;;
;;; ***** LOW SEGMENT *****
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; PUSHDOWN LISTS:
;;; FXP, FLP, P, SP
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS (FIXED, SET BY ALLOC)
;;; C(HIXM) HIGH WORD OF EXISTING MEMORY
;;; C(MAXNXM) HIGHEST WORD OF NXM THAT MAY BE USED
;;;
;;; ***** HIGH SEGMENT *****
;;; BSYSSG INITIAL SYSTEM CODE (PURE)
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BPFSSG INITIAL PURE LIST STRUCTURE
;;; IF1
SUBTTL VARIOUS PARAMETER CALCULATIONS
IFE .OSMIDAS-<SIXBIT \ITS\>,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
$FNAME .IFNM1
PRINTX \ \
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
IFE .OSMIDAS-<SIXBIT \DEC\>,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
ZZX==<FOO>
REPEAT 6,[
IRPNC ZZX←-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)↑←]
IFSN [Q][ ] PRINTX |Q|
TERMIN
ZZX==ZZX←6
]
TERMIN
;;; IF1
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
;;@ DEFNS 83 STANDARD AC, UUO, AND MACRO DEFINITIONS
;;; THIS FILE CONTAINS:
;;; STANDARD SYMBOLIC ACCUMULATOR DEFINITIONS.
;;; UUO DEFINITIONS:
;;; ERROR CALLS AND STRING TYPEOUT.
;;; COMPILED CODE TO INTERPRETER INTERFACES.
;;; VARIOUS UUOS USEFUL FROM DDT.
;;; .GLOBAL DECLARATIONS.
;;; .FORMAT DECLARATIONS.
;;; GENERAL MACRO DEFINITIONS [THAT ANY LOSER MIGHT WANT].
;;; SYMBOLIC NAMES RELATED TO ARRAYS.
;;; SYMBOLIC NAMES RELATED TO FILES.
;;; THE DEFINITIONS FOR MACLISP CONTAINED HEREIN
;;; ARE RELATIVELY STABLE. THIS FILE MAY BE .INSRT'D BY MIDAS
;;; FILES ASSEMBLED IN .FASL MODE TO DEFINE THESE THINGS.
;;; THE .GLOBAL DECLARATIONS IN PARTICULAR ARE FOR THE
;;; BENEFIT OF THESE .FASL FILES.
;;; IT IS A GOOD IDEA FOR .FASL FILES TO USE THE FASEND MACRO
;;; IN PLACE OF THE USUAL END STATEMENT.
SUBTTL ACCUMULATOR USAGE
NIL=0 ;ATOM HEADER FOR NIL
A=1 ;ARG 1; VALUE; MARKED FROM BY GC
B=2 ;ARG 2; MARKED FROM BY GC
C=3 ;ARG 3; MARKED FROM BY GC
AR1=4 ;ARG 4; MARKED FROM BY GC
AR2A=5 ;ARG 5; MARKED FROM BY GC
NACS==5 ;NUMBER OF ACS MARKED FROM BY GC - NO OTHER ACS MARKED
T=6 ;-<NO. OF ARGS> FOR LSUBR CALL; ALSO USED FOR JSP T,
TT=7 ;TEMP; OFTEN USED FOR ARGS TO INTERNAL ROUTINES
D=10 ;SOMEWHAT LESS TEMPORARY THAN TT
R=11 ;DITTO; SOMETIMES USED FOR JSP R,
F=12 ;SOMEWHAT LESS TEMPORARY THAN D AND R
FREEAC=13 ;UNUSED BY LISP, EXCEPT SAVED-USED-RESTORED BY GC
P=14 ;SUBROUTINE AND SYSTEM PDL POINTER ("REGULAR PDL")
FLP=15 ;FLONUM PDL POINTER ("FLOPDL")
FXP=16 ;FIXNUM PDL POINTER ("FIXPDL")
SP=17 ;LAMBDA-BINDINGS PDL POINTER ("SPECIAL PDL")
;;; PDL POINTERS ARE ALWAYS KEPT IN ACS. PDL POINTERS ARE NOT
;;; MARKED FROM, BUT PDL DATA ON REGULAR AND SPECIAL PDLS ARE
;;; PROTECTED FROM GARBAGE COLLECTION.
;;; FLP IS NOT USED BY LISP, EXCEPT AT LDATFL AND ERRIOJ,
;;; BUT PRIMARILY BY COMPILED NUMERICAL CODE.
;;; DO NOT DO RANDOM PUSH/POPS ON SP - USE BIND AND UNBIND ROUTINES.
;;; A FEW RANDOMLY USEFUL DEFINITIONS TO KEEP THINGS SYMBOLIC
;;; BUT WATCH OUT! DONT JUST RANDOMLY THINK YOU CAN CHANGE NASCII
;;; AND HAVE THINGS WIN, ESPECIALLY THE PACKING OF CHARS FOR
;;; PNAMES, AND THE SPECIAL OBARRAY ENTRIES FOR SCOS.
NASCII==200 ;NUMBER OF ASCII CHARS
BYTSWD==5 ;NUMBER OF ASCII BYTES PER WORD
SUBTTL TABLE OF GLOBAL SYMBOLS USED BY COMPILED FUNCTIONS
DEFINE GLBSYM B
IRP A,,[.SET,.MAP,PRINTA,SPECBIND,UNBIND,IOGBND,.LCALL
.UDT,ARGLOC,INUM,ST,FXNV1,PDLNMK,PDLNKJ,FIX1A
FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO
GOBRK,CARCDR,.STORE,NPUSH,PA3,QUNBOUND,FLTSKP,FXNV2
FXNV3,FXNV4,FIX2,FLOAT2,AREGET]
B
TERMIN
IFE QIO,[IRP A,,[UINITA,UTIN]
B
TERMIN
]
IFN QIO,[IRP A,,[INTREL,INTREL]
B
TERMIN
]
IRP A,,[INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0.0PUSH,NILPROPS,VBIND,%CXR,%RPX]
B
TERMIN
TERMIN
DEFINE SIXSYM B ;SIXBIT NAMES -- MUST MATCH GLBSYM
IRP A,,[*SET,*MAP,PRINTA,SPECBIND,UNBIND,IOGBND,*LCALL
*UDT,ARGLOC,INUM,NUMVAL,FXNV1,PDLNMK,PDLNKJ,FIX1A
FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO
GOBRK,CARCDR,*STORE,NPUSH,PA3,MAKUNBOUND,FLTSKP,FXNV2
FXNV3,FXNV4,FIX2,FLOAT2,AREGET]
B
TERMIN
IFE QIO,[IRP A,,[UINITA,UTIN]
B
TERMIN
]
IFN QIO,[IRP A,,[INTREL,INTREL]
B
TERMIN
]
IRP A,,[INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0*0PUSH,NILPROPS,VBIND,%CXR,%RPX]
B
TERMIN
TERMIN
;;; ADDITIONAL SYMBOLS FOR LAP AND .FASL HACKERS
DEFINE XTRSYM B
IFN ITS,[
IRP A,,[GETCOR,RINTERN]
B
TERMIN
] ;END OF IFN ITS
IFN BIGNUM,[
IRP A,,[BNCONS,NVSKIP]
B
TERMIN
] ;END OF IFN BIGNUM
IRP A,,[CPOPJ,CCPOPJ,POPAJ,POP1J,CINTREL,LWNACK,SIXMAK,SQUEEZE]
B
TERMIN
IFN QIO,[
IRP A,,[ALFILE,ALCHAN,XFILEP,FIL6BT,6BTNML,SIXATM,READ0A]
B
TERMIN
] ;END OF IFN QIO
IFN JOBQIO,[
IRP A,,[JOBTB,LOJOBA]
B
TERMIN
] ;END OF IFN JOBQIO
TERMIN
;;; SYMBOLS FOR COMPILED CODE
IFNDEF ITS, ITS==1
IFNDEF BIGNUM, BIGNUM==1
IFNDEF QIO, QIO==1
IFNDEF JOBQIO, JOBQIO==1
GLBSYM [.GLOBAL A]
XTRSYM [.GLOBAL A]
SUBTTL SYMBOLS FOR NUMBER-OF-ARGS CHECKING, AND .FORMAT
;;; SYMBOLS TO BE USED WITH FWNACK AND LWNACK.
;;; ORDINARILY ONE WRITES
;;; JSP TT,FWNACK
;;; FAXXX,,QZZZZZ
;;; IN EACH SYMBOL, THE 3.1 BIT (THESE ARE LEFT-HALF SYMBOLS)
;;; MEANS FSUBR. THE 3.2 BIT MEANS 0 ARGS IS OKAY; 3.3, 1 ARG;
;;; 3.4, 2 ARGS; ... ; 4.8, 15. ARGS; 4.9, > 15. ARGS.
;;; ITEMS IN THIS IRP MUST HAVE FIRST FOUR CHARS UNIQUE!!!
;;; IF YOU ADD STUFF HERE, ALSO FIX UP FASEND.
IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567
13456,234,345,234567,76543]
LA!X==0
IRPC Q,,[X]
IFSN Q,N, LA!X==LA!X+2←Q
.ALSO ZZ==Q
.ELSE LA!X==LA!X+<<777774←ZZ>&7777777>
TERMIN
FA!X==LA!X+1
TERMIN
;;; THE FOLLOWING FORMATS ARE HEREBY DECLARED ILLEGAL AS
;;; BEING REDUNDANT AND/OR GROSSLY CONFUSING.
;;; SEE THE MIDAS MANUAL FOR DETAILS.
;;; ,A
;;; ,A C
;;; ,A,
;;; ,A,C
;;; A B C
;;; A,
;;; A,B
;;; A,B C
;;; A,B,
;;; A,B,C
IRP X,,[14,15,16,17,25,30,34,35,36,37]
.FORMAT X,0
TERMIN
%SY==1,,537777 ;FLAG BITS FOR SQUOZE SYMBOLS IN DDT
%SYHKL==400000 ;HALF KILLED
%SYKIL==200000 ;FULLY KILLED
%SYLCL==100000 ;LOCAL
%SYGBL==40000 ;GLOBAL
SUBTTL GENERAL MACROS
DEFINE CONC A,B ;HAIRY CONCATENATOR MACRO
A!B!TERMIN
DEFINE % ;THIS IS GOOD FOR LIST STRUCTURE
,,.+1!TERMIN
DEFINE LOCKI ;LOCK OUT USER INTERRUPTS UNTIL UNLOCKI'D
PUSH FXP,INHIBIT
SETOM INHIBIT
TERMIN
DEFINE UNLOCKI ;RELEASE THE USER-INTERRUPT LOCK, AND CHECK TO SEE
PUSHJ P,INTREL ;IF ANY INTERRUPTS WERE STACKED UP WHILE IN LOCKED STATE
TERMIN
DEFINE LOCKTOPOPJ ;LOCK ALL THE ENSUING CODE UNTIL THE
PUSH P,CINTREL ;EXITING POPJ P,
LOCKI
TERMIN
DEFINE UNLKPOPJ ;UNLOCK, THEN POPJ P,
JRST INTREL
TERMIN
IRP PL,,[,FX]
DEFINE SAVE!PL AL/ ;CALLED LIKE SAVE A B C
IRPS AC,,AL
PUSH PL!P,AC
TERMIN
TERMIN
DEFINE RSTR!PL AL/ ;CALLED LIKE RSTR C B A
IRPS AC,,AL
POP PL!P,AC
TERMIN
TERMIN
TERMIN
DEFINE MACROLOOP COUNT,NAME,C ;FOR EXPANDING MANY MACROS
IFSN C,, .CRFOFF
REPEAT COUNT,[ CONC NAME,\.RPCNT
]
IFSN C,, .CRFON
TERMIN
IF1,[
;;; FEATURE SO THAT HAIRY SUMS OF BITS MAY BE WRITTEN NICELY.
;;; BITMAC FOO,FOO.
;;; CAUSES THE FORM
;;; FOO<A+B+C>
;;; TO EXPAND INTO THE FORM
;;; FOO.A+FOO.B+FOO.C
NBITMACS==0
DEFINE BITMAC XX,YY,ZZ=[1,,525252]
DEFINE XX<BITS>
IRPS J,K,[BITS]
YY!!J!K!TERMIN TERMIN
BITMA1 XX,YY,[ZZ]\NBITMACS
NBITMACS==NBITMACS+1
TERMIN
DEFINE BITMA1 XX,YY,ZZ,NN
DEFINE BTMC!NN
EXPUNGE XX,YY
XX==ZZ
YY==ZZ
IFSN [ZZ], IFGE <.TYPE ZZ>, EXPUNGE ZZ
TERMIN
TERMIN
IRP FOO,,[%TB,%TI,%TJ,%TX,%TO,%TS,%TC,%TG,%TT,%PI,%PJ]
IFDEF FOO, SV$!FOO==FOO .SEE BITMAC
.ELSE SV$!FOO==1,,525252
EXPUNGE FOO
TERMIN
BITMAC AS,AS. ;LH ASARS
BITMAC TTS,TTS. ;LH TTSARS
BITMAC FBT,FBT. ;LH F.MODE WORD IN FILE ARRAYS
BITMAC RS.,RS. ;FOR READER SYNTAX BITS
BITMAC RS%,RS%,525252 ;READER SYNTAX BITS, LH SHIFTED INTO RH
BITMAC IB,IB.,[525252,,525252] ;WORD 1 INTERRUPT BITS
BITMAC %TB,%TB,SV$%TB ;LH .TTY USER VARIABLE
BITMAC %TI,%TI,SV$%TI ;LH TTY IOCHNM BITS (SOME PER-IOT)
BITMAC %TJ,%TJ,SV$%TJ
BITMAC %TX,%TX,SV$%TX ;RH TTY CHARACTER BITS
BITMAC %TO,%TO,SV$%TO ;LH TTYOPT VARIABLE
BITMAC %TS,%TS,SV$%TS ;LH TTYSTS VARIABLE
BITMAC %TC,%TC,SV$%TC ;LH TTYCOM VARIABLE
BITMAC %TG,%TG,SV$%TG ;6-BIT BYTE TTYST1,TTYST2 GROUPS
BITMAC %TT,%TT,SV$%TT ;LH TTYTYP VARIABLE
BITMAC %PI,%PI,SV$%PI ;FULL WORD .PIRQC VARIABLE
BITMAC %PJ,%PJ,SV$%PJ ;LH .PIRQC VARIABLE
] ;END OF IF1
DEFINE INFORM R,S,T,U,V,W,X,Y,Z,$,%
PRINTX ≤ R!S!T!U!V!W!X!Y!Z!$!%
≤
TERMIN
DEFINE WARN R,S,T,U,V,W,X,Y,Z,$,%
WARN1 [R!S!T!U!V!W!X!Y!Z!$!%]
TERMIN
DEFINE WARN1 CRUFT
IFL 40-.LENGTH ≤CRUFT≤,[ .ERR ######
PRINTX ≤ ###### CRUFT
≤
]
.ELSE .ERR ###### CRUFT
TERMIN
;;; MACRO FOR .FASL LOSERS WHO .INSRT THIS FILE TO USE
;;; IN PLACE OF THE "END" PSEUDO. THIS GENERATES AN "END"
;;; AFTER PERFORMING SOME CLEANUP. MANY SYMBOLS ARE EXPUNGED
;;; SO THAT .FASL FILES WILL NOT SPEND INFINITE TIME TRYING TO
;;; PASS THEM TO DDT.
DEFINE FASEND
IF2,[
EXPUNGE QIO NASCII
EXPUNGE NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP
EXPUNGE LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX
EXPUNGE CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS
EXPUNGE NERINT
EXPUNGE %UDF %UBV %WTA %UGT %WNA %GCL %FAC %IOL
EXPUNGE %%UDF %%UBV %%WTA %%UGT %%WNA %%GCL %%FAC %%IOL
EXPUNGE ASAR TTSAR
EXPUNGE AS.JOB AS.FIL AS.RDT AS.OBA AS.SX AS.FX AS.FL AS.GCP
EXPUNGE TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC
EXPUNGE TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D
EXPUNGE FI.EOF FO.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.GC
EXPUNGE F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.AP FBT.CC FBT.FR
EXPUNGE F.CHAN F.DEV F.SNM F.PPN F.FN1 F.FN2
EXPUNGE F.RDEV F.RSNM F.RFN1 F.RFN2 F.FPOS LOPOFA
EXPUNGE TI.ST1 TO.TYP TI.ST2 ATO.LC
EXPUNGE AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FB.IOT LONBFA
EXPUNGE FB.BFL AB.CNT FB.STS AB.BP FB.NBF XB.AOB FB.WDC FB.BUF
IRPC X,,[AXI]
IRPC Y,,[DT]
IRPC Z,,[IO]
EXPUNGE X!!Y!!Z!C.SZ X!!Y!!Z!B.BS X!!Y!!Z!B.SZ
TERMIN
TERMIN
TERMIN
EXPUNGE J.INTF J.LFNM J.GC J.INTB J.STAD LOJOBA J.SYMS
IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567
13456,234,345,234567,76543]
EXPUNGE LA!X FA!X
TERMIN
MACROLOOP NBITMACS,BTMC,*
] ;END OF IF2
END
TERMIN
;;; USEFUL MACRO FOR .FASL FILES. CAUSES LOADING TO PRINT MESSAGE.
DEFINE VERPRT NAME
.SXEVAL (COND ((STATUS NOFEATURE NOLDMSG)
(COND ((STATUS FEATURE NEWIO)
(TERPRI MSGFILES)
(TYO #73 MSGFILES)
(PRINC (QUOTE LOADING/ NAME/ ) MSGFILES)
(DO ((N #<.FNAM2> (LSH N #6 )))
((ZEROP N))
(TYO (PLUS #40 (LSH N #-30. ))
MSGFILES)))
(T (TERPRI)
(TYO #73 )
(PRINC (QUOTE LOADING/ NAME/ ))
(DO ((N #<.FNAM2> (LSH N #6 )))
((ZEROP N))
(TYO (PLUS #40 (LSH N #-30. ))))))))
TERMIN
SUBTTL ONE-LINE CONDITIONAL MACROS
;;; HOPEFULLY THESE WILL HELP MAKE SOME CODE LESS MESSY TO READ.
;;; PREFACING A LINE OF CODE WITH ONE OF THESE SYMBOLS TELLS MIDAS
;;; TO ASSEMBLE THAT LINE ONLY UNDER THE SPECIFIED CONDITION.
;;; EXAMPLE:
;;;
;;; FOO: MOVE A,(P)
;;; 10$ PUSHJ P,10HACK ;THIS LINE IS FOR DEC-10 ONLY
;;; MOVE A,-1(P)
;;; NW% PUSHJ P,OLDHAK ;THIS LINE IS FOR OLD I/O ONLY
;;; POPJ P,
DEFINE 10$
IFN D10,TERMIN
DEFINE 10%
IFN ITS,TERMIN
DEFINE SA%
IFE SAIL,TERMIN
DEFINE SA$
IFN SAIL, TERMIN
DEFINE 10X
IFN TENEX,TERMIN
;;; EVENTUALLY, SWITCH "PAGING" AND PG$, PG% WILL BE GOOD IDEA.
;;; FOOLISH NEW READER FLAG (HISTORICAL ARTIFACT -- FLUSH EVENTUALLY)
DEFINE NW$
IFN NEWRD,TERMIN
DEFINE NW%
IFE NEWRD,TERMIN
DEFINE Q%
IFE QIO,TERMIN
DEFINE Q$
IFN QIO,TERMIN
DEFINE BG$
IFN BIGNUM,TERMIN
DEFINE BG%
IFE BIGNUM,TERMIN
SUBTTL FORMAT OF ARRAYS
;;; ARRAYS ARE POINTED TO BY A TWO-WORD SAR (SPECIAL ARRAY CELL).
;;; SARS RESIDE IN A SPECIAL SPACE CALLED SAR SPACE.
ASAR==0 ;SAR POINTER POINTS TO ASAR (CODE DEPENDS ON THIS)
TTSAR==1 ;TTSAR COMES JUST AFTER IT
;;; THE FIRST WORD OF THE SAR, CALLED THE ASAR, POINTS TO THE ARRAY
;;; HEADER; PUSHJ'ING INDIRECTLY THOUGH IT GETS TO THE ARRAY
;;; SUBSCRIPT EVALUATION CODE. THE LEFT HALF, EXCLUDING THE
;;; INDIRECT AND INDEX BITS, CONTAINS VARIOUS BITS DESCRIBING
;;; THE TYPE OF THE ARRAY:
AS.JOB==10000 ;JOB ARRAY (IN QIO ONLY)
AS.FIL==4000 ;FILE ARRAY (IN QIO ONLY)
AS.RDT==2000 ;READTABLE
AS.OBA==1000 ;OBARRAY
AS.SX==400 ;S-EXPRESSION ;THESE ARE ACCESS
AS.FX==200 ;FIXNUM ; METHODS - AT LEAST
AS.FL==100 ;FLONUM ; ONE MUST BE ON
AS.GCP==40 ;GC SHOULD USE AOBJN PTR TO MARK ARRAY
;;; THE SECOND WORD, CALLED THE TTSAR, POINTS TO THE ARRAY DATA
;;; AND IS INDEXED BY ACCUMULATOR TT. ITS LEFT HALF, EXCLUDING
;;; AGAIN THE INDIRECT AND INDEX BITS, CONTAIN MORE INFORMATION
;;; ABOUT THE ARRAY:
TTS.CL==40000 ;CLOSED FILE
TTS.IM==2000 ;1 => IMAGE ;BOTH 0
TTS.BN==1000 ;1 => BINARY (FIXNUM) ; => ASCII
TTS.TY==400 ;0 => DSK-TYPE, 1 => TTY
TTS.IO==200 ;0 => IN, 1 => OUT
TTS.CN==100 ;COMPILED CODE NEEDS THIS SAR
TTS.GC==40 ;USED AS MARK BIT BY GC
TTSDIM==410300 ;BYTE POINTER FOR # OF DIMENSIONS (1-5)
TTS.1D==100000 ;DEFINITIONS
TTS.2D==200000 ; FOR SPECIFYING
TTS.3D==300000 ; NUMBER OF
TTS.4D==400000 ; ARRAY
TTS.5D==500000 ; DIMENSIONS
;;; S-EXPRESSION ARRAYS HAVE THE FOLLOWING FORM:
;;; -<# WDS FOR GC MARK>,,<1ST WD OF DATA TO MARK>
;;; HEADER: JSP TT,<N>DIMS ;ASAR POINTS HERE; N=# OF DIMS
;;; <ADDRESS OF SAR> ;LH USED BY FLASH
;;; <DIMENSION 1>
;;; ...
;;; <DIMENSION N>
;;; DATA: <ENTRY 0>,,<ENTRY 1> ;TTSAR POINTS HERE
;;; ... ;DATA PACKED 2/WD
;;; <ENTRY X-1>,,<ENTRY X>
;;;
;;; THE FORMAT OF A NUMBER ARRAY IS AS FOLLOWS:
;;; <GC AOBJN PTR> ;PROBABLY MEANINGLESS
;;; HEADER: PUSH P,CFIX1 ;CFLOAT1 FOR A FLONUM ARRAY
;;; JSP TT,<N>DIMF ;N=# OF DIMS
;;; <ADDRESS OF SAR> ;LH USED BY FLASH
;;; <DIMENSION 1>
;;; ...
;;; <DIMENSION N>
;;; DATA: <ENTRY 0> ;TTSAR POINTS HERE
;;; <ENTRY 1> ;FULL-WORD DATA 1/WD
;;; ...
;;; <ENTRY X>
;;; THE AOBJN POINTER AT THE TOP OF EACH ARRAY IS MEANINGFUL ONLY
;;; IF THE AS.GCP BIT IS 1 IN THE ARRAY'S ASAR; IT INDICATES
;;; WHAT ENTRIES IN THE ARRAY GC SHOULD MARK. FOR S-EXPRESSION
;;; ARRAYS, THIS IS GENERALLY THE ENTIRE ARRAY; FOR OBARRAYS,
;;; IT INCLUDES THE BUCKETS BUT NOT THE SCO TABLE. FOR
;;; READTABLES, WHICH ARE OTHERWISE FIXNUM ARRAYS, UNDER NEWRD
;;; THE GC AOBJN POINTER INDICATES THAT THE LIST OF CHARACTER
;;; MACRO FUNCTIONS SHOULD BE MARKED.
;;; NOTE THAT IF SUCH AN AOBJN POINTER IS OF THE FORM <-N>,,<DATA>,
;;; THEN 2*N ENTRIES ARE MARKED; THE LEFT HALF IS THE NUMBER
;;; OF WORDS TO BE MARKED, WITH TWO ENTRIES PER WORD.
;;; CORRESPONDS TO ARRAY TYPE BITS IN ASAR'S.
SUBTTL DEFINITIONS OF UUO'S
;;; NOTE: LERR < LER3 < ERINT < SERINT -- SEE ERRFRAME.
LERR=1←33 ;LISP ERROR; AC FIELD=0 => MSG IS SIXBIT, ELSE S-EXP
ACALL=2←33 ;KLUDGY FAST UUO FOR NCALLS TO ARRAYS
AJCALL=3←33 ;AJCALL:ACALL :: JCALL:CALL
LER3=4←33 ;EPRINT, THEN LERR
ERINT=5←33 ;A CORRECTABLE ERROR
PP=6←33 ;SEXP TYPE OUT FROM DDT
STRT=7←33 ;STRING TYPEOUT
SERINT=10←33 ;LIKE ERINT, BUT S-EXPRESSION MESSAGE.
TP=11←33 ;PRINTS ST ENTRY FOR A GIVEN LOCATION
IOJRST=12←33 ;JRST TO ADR AFTER PUTTING I/O ERROR MSG IN C
UUOMAX==12 ;NO OF ERROR-TYPE UUO'S
CALL=14←33 ;BASIC CALL FROM COMPILED CODE TO INTERFACE TO INTERPRETER
JCALL=CALL+1←33 ;4.1 BIT ON MEANS JRST TO FUNCTION RATHER THAN PUSHJ
CALLF=CALL+2←33 ;4.2 BIT ON MEANS NEVER CONVERT UUO INTO PUSHJ [OR JRST]
JCALLF=CALL+3←33
NCALL=20←33 ;4.5 BIT MEANS NUMBER FUNCTION CALL
NJCALL=NCALL+1←33
NCALLF=NCALL+2←33
NJCALF=NCALL+3←33
NUUOCLS==NJCALF←-33-CALL←-33
;;; SPECIAL INTERPRETATION OF STRT AC FIELD FOR QIO:
;;; AC FIELD OUTPUT TO
;;; 0 OUTFILES IF ↑R SET; TTY IF ↑W SET
;;; 17 MSGFILES
;;; X FILE(S) IN ACCUMULATOR X
;;; ERINT AND SERINT ARE DECODED BY THEIR ACCUMULATOR FIELDS.
;;; HERE ARE SOME SYMBOLS FOR REFERENCING THEM.
NERINT==0
IRPS X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC,IOL]
%!X=ERINT .IRPCNT,
%%!X=SERINT .IRPCNT,
DEFINE X CRUFT
%!X [SIXBIT ≤CRUFT≤]
TERMIN
NERINT==NERINT+1
TERMIN
;;; SHORT FORM ATOM WHAT IS IT?
;;;
;;; 0) UDF UNDEF-FNCTN UNDEFINED FUNCTION (FUNCTION IN A)
;;; 1) UBV UNBND-VRBL UNBOUND VARIABLE BEING EVAL'ED (ATOM IN A)
;;; 2) WTA WRNG-TYPE-ARGS WRONG TYPE OF ARGUMENTS FOR A FUNCTION (ARG IN A)
;;; 3) UGT UNSEEN-GO-TAG GO TO A TAG THAT'S NOT THERE (TAG IN A)
;;; 4) WNA WRNG-NO-ARGS WRONG NUMBER OF ARGS TO A FUNCTION (FORM IN A)
;;; 5) GCL GC-LOSSAGE GC LOST (A = NAME OF SPACE: LIST...)
;;; 6) FAC FAIL-ACT RANDOM LOSSAGE (ARG IS UP TO CALLER)
;;; 7) IOL IO-LOSSAGE ;QIO ONLY ;I/O LOSSAGE
SUBTTL FORMAT OF FILE ARRAYS
;;; FILE ARRAYS ARE ARRAYS WHICH HAVE THE AS.FIL BIT SET
;;; IN THE ASAR AND SOME EXTRA BITS IN THE TTSAR DESCRIBING
;;; THE TYPE OF ARRAY. PRESENTLY THERE EXIST SIX KINDS
;;; OF FILE ARRAY: ASCII INPUT, ASCII OUTPUT, TTY INPUT,
;;; TTY OUTPUT, BINARY INPUT, AND BINARY OUTPUT.
;;; A FILE ARRAY CONTAINS A NUMBER OF VARIABLES RELATED TO
;;; THE FILE, PLUS A BUFFER FOR DATA (EXCEPT FOR TTY).
;;; THE NAMES OF THE FILE ARRAY COMPONENTS INDICATE THE
;;; TYPES OF FILE ARRAYS TO WHICH THEY ARE APPLICABLE:
;;; F. ANY FILE ARRAY AI. ASCII INPUT ONLY
;;; FI. INPUT ONLY TI. TTY INPUT ONLY
;;; FO. OUTPUT ONLY XI. BINARY INPUT ONLY
;;; FA. ASCII ONLY AO. ASCII OUTPUT ONLY
;;; FT. TTY ONLY TO. TTY OUTPUT ONLY
;;; FX. BINARY ONLY XO. BINARY OUTPUT ONLY
;;; AX. ASCII/BINARY ONLY AT. ASCII/TTY ONLY
;;; FB. BLOCK MODE FC. CHAR (UNIT) MODE
;;; XXB. XX BLOCK MODE XXC. XX CHAR MODE
;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT
;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED.
;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA
;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR).
FI.EOF==0 ;EOF FUNCTION
FO.EOP==0 ;END OF PAGE FUNCTION (BINARY N/A)
FJ.INT==0 ;INT FN FOR USR DEVICE
FI.BBC==1 ;BUFFERED BACK CHARS (BINARY N/A)
; LEFT HALF: SINGLE CHAR (3.8=1 IF ANY,
; SO CAN DISTINGUISH ↑@ FROM NONE)
.SEE $DEVICE
; RIGHT HALF: LIST OF CHARS
FI.BBF==2 ;LIST OF BUFFERED BACK FORMS (BINARY N/A)
TI.BFN==3 ;RH IS BUFFER-FORWARD FUNCTION FOR READ
FT.CNS==4 ;ASSOCIATED TTY FILE FOR OTHER DIRECTION
;SLOTS 5, 6, AND 7 ARE RESERVED FOR EXPANSION
F.GC==10 ;NUMBER OF SLOTS GC SHOULD EXAMINE
F.MODE==10 ;MODE BITS FOR OPEN
;FOR ITS:
FBT.CM==400000 ;4.9 0=BUFFERED, 1=CHARMODE
FBT.SA==200000 ;4.8 SAIL CHARS (AFFECTS CHARPOS)
FBT.CP==100000 ;4.7 CURSORPOS WILL SUCCEED (?);
; REFLECTS %TOMVU (CAN MOVE UP)
FBT.LN==40000 ;4.6 HANDLE TTY IN LINE MODE
FBT.AP==20000 ;4.5 OPENED IN APPEND MODE
FBT.EC==10000 ;4.4 OUTPUT TTY IN ECHO AREA
FBT.FR==4000 ;4.3 FORCE-FEED REQUIRED (INVERSE
; OF (STATUS TTYREAD))
FBT.SE==2000 ;4.2 TTY CAN SELECTIVELY ERASE
FBT.FU==1000 ;4.1 TTY SHOULD READ/PRINT FULL 12.-BIT
; CHARACTERS (FIXNUM MODE)
FBT.SI==400 ;3.9 USE SIOT FOR I/O TRANSFERS
; (ONLY IMPLEMENTED FOR OUTPUT NOW)
FBT.CA==40 ;3.6 CLA
;1.4-1.3 0=ASCII, 1=FIXNUM, 2=IMAGE
;1.2 0=DSK, 1=TTY
;1.1 0=INPUT, 1=OUTPUT
F.CHAN==11 ;I/O CHANNEL NUMBER
;;; FROM F.DEV TO F.RFN2 ARE USED BY JOB ARRAYS ALSO.
;;; MUST HAVE (F.DEV, F.SNM/F.PPN, F.FN1, F.FN2) IN THAT ORDER
F.DEV==12 ;DEVICE NAME
F.SNM==13 ;SNAME (ITS)
F.PPN==13 ;PROJ-PROG NUMBER (DEC-10)
F.FN1==14 ;FILE NAME 1
F.FN2==15 ;FILE NAME 2
F.RDEV==16 ;.RCHST'D DEVICE NAME
F.RSNM==17 ;.RCHST'D SNAME
F.RFN1==20 ;.RCHST'D FILE NAME 1
F.RFN2==21 ;.RCHST'D FILE NAME 2
F.FPOS==22 ;FILEPOS OF JUST BEYOND END OF BUFFER
; IN WORDS (CHARS FOR SINGLE ASCII)
;NOTE THAT AB.BP CONTAINS SOME FILEPOS
; INFO FOR BLOCK ASCII FILES
;-1 => NOT RANDOMLY ACCESSIBLE
LOPOFA==23 ;LENGTH OF PLAIN OLD FILE ARRAY (SEE ALFILE)
;;; BEWARE: .RCHST MAY CLOBBER FOLLOWING WORD OR TWO ALSO.
TI.ST1==23 ;TTY STATUS WORD 1 (ITS)
TI.ST2==24 ;TTY STATUS WORD 2 (ITS)
ATO.LC==24 ;NORMALLY ZERO:
; POSITIVE => LAST CHAR WAS /, NEXT
; MAY THEREFORE EXCEED LINEL
; NEGATIVE => LAST CHAR WAS CR,
; MAY NEED TO SUPPLY AN LF
AT.CHS==25 ;CHARPOS
AT.LNN==26 ;LINENUM
AT.PGN==27 ;PAGENUM
FO.LNL==30 ;LINE LENGTH (BINARY N/A)
;MAY BE NEGATIVE (SEE STERPRI)
FO.PGL==31 ;PAGE LENGTH (BINARY N/A)
;SLOTS 32-37 ARE RESERVED FOR EXPANSION
LONBFA==40 ;LENGTH OF NON-BUFFERED FILE ARRAY
;;; EVERYTHING AFTER THIS IS ONLY FOR FILES WITH BUFFERS
FB.BFL==40 ;BUFFER LENGTH
AB.CNT==41 ;CHAR COUNT WITHIN BUFFER (ITS)
FB.STS==41 ;FILE STATUS (DEC10)
AB.BP==42 ;BYTE POINTER (RELOC) (ITS)
XB.AOB==42 ;AOBJN POINTER FOR PICKING UP WORDS (RELOC) (ITS)
FB.NBF==42 ;USE BIT, SIZE, ADR NEXT BUF (RELOC) (DEC10)
FB.IOT==43 ;.IOT POINTER TO BUFFER (RELOC) (ITS)
FB.WDC==43 ;BOOKKEEPING, WORD COUNT (DEC10)
FB.BYT==44 ;LH OF INITIAL BYTE POINTER,,BYTES PER WORD (ITS)
;NOTE THAT @(17) BITS ARE ALWAYS ZERO
;SLOTS 45-47 ARE RESERVED FOR EXPANSION
FB.BUF==50 ;BEGINNING OF BUFFER
;FOR TTY INPUT, THE "BUFFER" IS AN ARRAY
; OF INTERRUPT FUNCTIONS FOR EACH CHAR
;;; FOR DEC-10 MUST USE THE DEVSIZ UUO TO GET BUFFER SIZE.
;;; THE FOLLOWING ARE THEREFORE ONLY FOR ITS.
;IRPC X,,[AXI]
;IRPC Y,,[DT]
;IRPC Z,,[IO]
ADIC.SZ==LONBFA
ADIB.BS==100 ;GOOD RANDOM SIZE
ADIB.SZ==FB.BUF+ADIB.BS
ADOC.SZ==LONBFA
ADOB.BS==100 ;GOOD RANDOM SIZE
ADOB.SZ==FB.BUF+ADOB.BS
ATIC.SZ==FB.BUF+NASCII/2 ;ROOM FOR INTERRUPT FUNCTIONS
ATIB.BS==-1
ATIB.SZ==-1 ;BLOCK MODE ILLEGAL
ATOC.SZ==LONBFA
ATOB.BS==100 ;GOOD RANDOM SIZE
ATOB.SZ==FB.BUF+ATOB.BS
XDIC.SZ==LONBFA
XDIB.BS==100 ;GOOD RANDOM SIZE
XDIB.SZ==FB.BUF+XDIB.BS
XDOC.SZ==LONBFA
XDOB.BS==100 ;GOOD RANDOM SIZE
XDOB.SZ==FB.BUF+XDOB.BS
XTIC.SZ==FB.BUF+NASCII/2 ;ROOM FOR INTERRUPT FUNCTIONS
XTIB.BS==-1
XTIB.SZ==-1 ;BLOCK MODE ILLEGAL
XTOC.SZ==LONBFA
XTOB.BS==100 ;GOOD RANDOM SIZE
XTOB.SZ==FB.BUF+XTOB.BS
IDIC.SZ==LONBFA
IDIB.BS==100 ;GOOD RANDOM SIZE
IDIB.SZ==FB.BUF+IDIB.BS
IDOC.SZ==LONBFA
IDOB.BS==100 ;GOOD RANDOM SIZE
IDOB.SZ==FB.BUF+IDOB.BS
ITIC.SZ==FB.BUF+NASCII/2 ;ROOM FOR INTERRUPT FUNCTIONS
ITIB.BS==-1
ITIB.SZ==-1 ;BLOCK MODE ILLEGAL
ITOC.SZ==LONBFA
ITOB.BS==100 ;GOOD RANDOM SIZE
ITOB.SZ==FB.BUF+ITOB.BS
;TERMIN
;TERMIN
;TERMIN
SUBTTL FORMAT OF JOB ARRAYS
;;; JOB ARRAYS ARE ARRAYS WHICH HAVE THE AS.JOB BUT SET
;;; IN THE ASAR. THE TTS.CL BIT IS RELEVANT HERE ALSO,
;;; INDICATING A CLOSED JOB ARRAY.
;;; THE ARRAY CONTAINS VARIOUS DATA ASSOCIATED WITH THE JOB.
;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT
;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED.
;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA
;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR).
J.INTF==0 ;INTERRUPT FUNCTION (NEEDED BY INT SYSTEM)
J.CINT==1 ;CHANNEL INTERRUPT FUNCTION
J.LFNM==2 ;LOAD FILE NAMELIST?
J.GC==2 ;NUMBER OF SLOTS GC SHOULD EXAMINE
;SLOTS 3-12 RESERVED
;;; F.DEV THROUGH F.RFN2 (12 TO 21) APPLY TO JOB ARRAYS ALSO.
J.INTB==22 ;INTERRUPT BIT, OR ZERO FOR FOREIGN JOB
J.STAD==23 ;START ADDRESS
LOJOBA==100
J.SYMS==100 ;START OF SYMBOL TABLE, IF ANY
;;@ END OF DEFNS 83
LVRNO==.FNAM2
IFN <LVRNO←-36>-'9, LVRNO==<LVRNO←-6>+<SIXBIT \1\>
PRINTX \VERSION=\ ;PRINT OUT VERSION OF THIS LISP
$FNAME .OFNM2
PRINTX \[\ ;CARRIAGE RETURN
$FNAME LVRNO
PRINTX \]
\
;;; HACK FLAGS AND PARAMETERS
IRP S,,[ITS,D10,SAIL,TENEX,BIGNUM,EDFLAG,FUNAFL,HNKLOG,USELESS
OBTSIZ,SEGLOG,MOBIOF,ML]
INFORM [S=]\S
TERMIN
PRINTC \REDEFINITIONS:
\
.INSRT TTY:
PRINTC \
\
IFE ITS, MOBIOF==0
.ELSE IFE ML, MOBIOF==1
OBTSIZ==OBTSIZ\1 ;MUST BE ODD
IFN QIO,[
NSTAT==1
MOBIOF==0
] ;END OF IFN QIO
IFE QIO, JOBQIO==0
IFN SAIL, D10==1
IFGE HNKLOG-SEGLOG, .FATAL HNKLOG TOO BIG!
;;; CANONICALIZE BITS
IRP X,Y,[ITS,D10,TENEX]
IRP Z,,[Y]
IFN X*Z, .FATAL BOTH X AND Z SPECIFIED
TERMIN
TERMIN
IFE ITS+D10+TENEX, .FATAL SO MAYBE YOU'RE ASSEMBLING FOR THE NULL MACHINE?
;;; IF1
;;; LOSING KL10 HAS A FIX INSTRUCTION
EXPUNGE FIX
IFN ITS,[ ;THIS MUST PRECEDE THE "$INSRT MACS" BELOW
IFNDEF %TOOVR, .INSRT SYSENG;TTY DEFS
] ;END OF IFN ITS
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
;;@ MACS 45 LOTSA MOBY MACROS
SUBTTL RANDOM MACROS
;;; MACRO TO REMOVE SYMBOLS OF THE FORM "GXXXXX"
DEFINE GEXPUN
DEFFLUSH
.GSSET 0
STPFL==0
.TAG FOO FLUSH
IFE STPFL, .GO FOO
TERMIN
DEFINE DEFFLUSH \SYM
DEFINE FLUSH \ZZX
IFSE SYM,ZZX, STPFL==1
EXPUNGE ZZX
TERMIN
TERMIN
DEFINE HAOLNG NM,N
RADIX 2
NM==HAOWNG \N
RADIX 8
TERMIN
DEFINE HAOWNG A
.LENGTH /A/
TERMIN
DEFINE MAYBE DEF
IF1,[
IRPS SYM,,[DEF]
IFNDEF SYM, DEF
.ISTOP
TERMIN
]
TERMIN
DEFINE TBLCHK START,LENGT
IFN .-<START>-<LENGT>, WARN [WRONG LENGTH TABLE]
TERMIN
DEFINE SKOTT X,Y ;SKIP ON TT (ACCORDING TO BIBOP TYPE BITS)
IFN TT-<X>, MOVEI TT,(X)
LSH TT,-SEGLOG
IFN <Y>-LS,[
MOVE TT,ST(TT)
TLNN TT,<Y>
]
.ELSE SKIPL TT,ST(TT)
TERMIN
IFE QIO,[
DEFINE TSOPEN A,B
.OPEN A,B
JSP T,OPNER
TERMIN
DEFINE OPNGEN A,B,E
A!OPN:
.OPEN A!C,O!A!C
JSP T,OPNER
AOS A!OPD
POPJ P,
TERMIN
;;; HAIRY MACRO TO GENERATE WORDS OF ASCII CODE SIMILAR TO ASCIZ.
;;; HAS THE STRANGE EFFECT OF CONVERTING PARENTHESES TO BRACKETS;
;;; THIS IS SO THAT CODE WILL NOT CONTAIN UNMATCHED BRACKETS (WHICH
;;; CONFUSE MIDAS WHEN HANDLING CONDITIONAL CODE). ALSO CONVERTS
;;; QUESTION MARKS TO RUBOUTS, FOR CODE THAT WANTS SUCH THINGS.
DEFINE ASCIB CHARS
.BYTE 7
IRPC X,,[CHARS]
IFSE [X](, 133
IFSE [X]), 135
IFSE [X]?, 177
IFSN [X](, IFSN [X]), IFSN [X]?, "X
TERMIN
0
.BYTE
TERMIN
] ;END OF IFE QIO
SUBTTL PION, PIOF, $LOSEG, $HISEG, INTON
IFN D10,[
DEFINE PION
PUSHJ P,UPCHK
TERMIN
DEFINE PIOF
SKIPGE UPCOK
SETZM UPCOK
TERMIN
DEFINE $LOSEG ;MACRO TO SWITCH TO LOW SEGMENT FOR 2SEG ASSEMBLY
IFN %LOSEG+1,[
%HISEG==.-HILOC
LOC FIRSTLOC+%LOSEG
%LOSEG==-1
CURSTD==STDLO
] ;END OF IFN %LOSEG+1
.ELSE WARN [ALREADY IN LOW SEGMENT]
TERMIN
DEFINE $HISEG ;MACRO TO SWITCH TO HIGH SEGMENT FOR 2SEG ASSEMBLY
IFN %HISEG+1,[
%LOSEG==.-FIRSTLOC
LOC HILOC+%HISEG
%HISEG==-1
CURSTD==STDHI
] ;END OF IFN %HISEG+1
.ELSE WARN [ALREADY IN HIGH SEGMENT]
TERMIN
] ;END OF IFN D10
IFN ITS,[
IFE QIO,[
DEFINE PION
.SUSET PINBL
TERMIN
] ;END OF IFE QIO
IFN QIO,[
DEFINE PION ;ENABLE INTERRUPT SYSTEM
.SUSET PINBL
.SUSET PINBL+1
.SUSET PINBL+2
TERMIN
DEFINE INTON ;INITIALLY TURN ON INTERRUPT SYSTEM
.SUSET INTNBL
.SUSET INTNBL+1
.SUSET INTNBL+2
.SUSET INTNBL+3
TERMIN
] ;END OF IFN QIO
DEFINE PIOF ;DISABLE INTERRUPT SYSTEM
.SUSET PIHOLD
TERMIN
] ;END OF IFN ITS
SUBTTL PGBOT, [PGTOP], PAGEUP, SEGUP, SPCBOT, SPCTOP
;;; NOTE THAT PGBOT DEFINES PGTOP FOR THE NEXT USE, WHILE
;;; PGTOP IS AUTO-EXPUNGING (AND VICE VERSA).
DEFINE DPGBOT
DEFINE PGBOT SPC
PGTPMK==.
DEFINE PGBOT SPC1
WARN [ILLEGAL PGBOT SPC1]
TERMIN
DEFINE PGTOP SPC1,CRUFT
IFSN SPC1,SPC, WARN [PGTOP SPC1 DOESN'T MATCH PGBOT SPC]
CONC CPG,\NPGTPS,: CONSTANTS
CONC ECPG,\NPGTPS,::
PGTOP1 \NPGTPS,\.-PGTPMK,[CRUFT]
NPGTPS==NPGTPS+1
DPGBOT
TERMIN
TERMIN
DEFINE PGTOP SPC,CRUFT
WARN [ILLEGAL PGTOP SPC,CRUFT]
TERMIN
TERMIN
DPGBOT
DEFINE PGTOP1 N,SIZE,STUFF
PRINTX ≤ P!N: SIZE [STUFF]
≤
TERMIN
.XCREF PGTOP1
DEFINE PAGEUP
LOC .RL1+<<.-.RL1+CURSTD+PAGSIZ-1>&PAGMSK>-CURSTD
TERMIN
DEFINE SEGUP PT
LOC .RL1+<<PT-.RL1+CURSTD+SEGSIZ-1>&SEGMSK>-CURSTD
TERMIN
DEFINE SPCBOT SPC
ZZ==.-.RL1
ZZY==.TYPE B!SPC!SG
IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[
IFN B!SPC!SG-., WARN [FORMERLY B!SPC!SG=]\B!SPC!SG,[, BUT NOW B!SPC!SG=]\ZZ
]
IFN <ZZ+CURSTD>&SEGKSM, WARN \ZZ+CURSTD,[=BAD BOUNDARY FOR B!SPC!SG]
B!SPC!SG==.
TERMIN
;;; NOTE WELL! ZZW MUST BE SAFE ACROSS THE SPCTOP MACRO
DEFINE SPCTOP SPC,TYP,CRUFT
ZZ==.
SEGUP .
ZZX==<.-B!SPC!SG>/SEGSIZ
ZZY==.TYPE N!SPC!SG
IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[
IFN N!SPC!SG-ZZX, WARN [FORMERLY N!SPC!SG=]\N!SPC!SG,[, BUT NOW N!SPC!SG=]\ZZX
]
N!SPC!SG==ZZX
IFL ZZX-5, SPCTP1 \ZZX,[CRUFT]\<.-ZZ>
IFGE ZZX-5, SPCTP2 \ZZX,[CRUFT]\<.-ZZ>
TERMIN
DEFINE SPCTP1 N,CRUFT,U
IRP Q,,[0,1,2,3,4]R,,[ZERO,ONE,TWO,THREE,FOUR]
IFE N-Q,[
PRINTX ≤ ***** R CRUFT SEGMENT≤
IFN N-1, PRINTX \S\
IFN U, PRINTX \ [U UNUSED WORDS]\
PRINTX \
\
]
IFE N-Q, .ISTOP
TERMIN
TERMIN
DEFINE SPCTP2 N,CRUFT,U
IRP Q,,[5,6,7,10,11,12,13,14,15,16,17,20,21,22
23,24,N]R,,[FIVE,SIX,SEVEN,EIGHT,NINE,TEN
ELEVEN,TWELVE,THIRTEEN,FOURTEEN,FIFTEEN,SIXTEEN,SEVENTEEN
EIGHTEEN,NINETEEN,TWENTY,N (OCTAL)]
IFE N-Q,[
PRINTX ≤ ***** R CRUFT SEGMENT≤
IFN N-1, PRINTX \S\
IFN U, PRINTX \ [U UNUSED WORDS]\
PRINTX \
\
]
IFE N-Q, .ISTOP
TERMIN
TERMIN
.XCREF SPCTP1 SPCTP2
SUBTTL PURTRAP, IOCTRAP, 2DIF, AND INTPRO MACROS
;;; FEATURE FOR AUTOMATIC TRAPOUT ON PURE PAGE VIOLATIONS
;;; STANDARD USAGE IS TO REPLACE
;;; MOVEM X,Y ;COULD CAUSE PURE PAGE TRAP
;;; WITH
;;; PURTRAP PATCH-LOC,AC, MOVEM X,Y
;;; IF THE INSTRUCTION CAUSES A PURE PAGE VIOLATION,
;;; THEN THE PURE PAGE TRAP HANDLER WILL TRANSFER TO FOO,
;;; WITH ALL ACS, ETC. INTACT (HOPEFULLY), RATHER THAN
;;; ERRORING OUT, WHICH IS THE DEFAULT. SEE PURPGI.
;;; FOR DEC-10, THERE IS AN EXPLICIT CHECK FOR TRYING TO CLOBBER
;;; THE HISEG.
;;; FOR QIO, A SIMILAR FEATURE FOR IOC TRAPS
;;; STANDARD USAGE IS:
;;;
;;; BAR: XCT D ;D HAS .IOT
;;; IOCTRAP TT,FOO,N ;N IS OPTIONAL
;;; <MORE CODE>
;;;
;;; IF THE INSTRUCTION AT BAR CAUSES AN IOC ERROR,
;;; THEN THE IOC ERROR CODE IS PUT INTO ACCUMULATOR TT,
;;; AND CONTROL TRANSFERRED TO FOO WITH ALL OTHER ACS INTACT.
;;; IF N IS GIVEN, ONLY IOC ERROR CODE N IS TRAPPED.
IFN ITS,[
DEFINE PURTRAP X,B-INST
INST
Q% PURTR1 \.,\NPURTR,A,X
Q$ PURTR1 \.-1,\NPURTR,D,X
NPURTR==NPURTR+1
TERMIN
DEFINE PURTR1 L,N,AC,X
DEFINE ZZP!N
CAIN AC,L
HRROI AC,X
TERMIN
TERMIN
IFN QIO,[
DEFINE IOCTRAP AC,X,N
IOCTR1 \.-QIO,\NIOCTR,AC,X,N
NIOCTR=NIOCTR+1
TERMIN
DEFINE IOCTR1 L,N,AC,X,N
DEFINE ZZI!N
IFSN [N],[
CAIE D,N
JRST .+3
]
CAIN R,L
MOVE R,[SETZ X(AC)]
TERMIN
TERMIN
] ;END OF IFN QIO
;;; FOR COMMENTS ON 2DIF, SEE BELOW
DEFINE 2DIF INST,X,Y
<INST>\<,,<X>-<Y>>
TERMIN
] ;END OF IFN ITS
IFN D10,[
DEFINE PURTRAP X,B-INST
CAIL B,HILOC
JRST X
INST
TERMIN
;;; FEATURE FOR TWO-SEGMENT DEC-10 ASSEMBLIES TO WIN ON THE
;;; MANY INSTRUCTIONS IN LISP WHICH ARE OF THE FORM
;;; JRST FOO-BAR(X)
;;; WHERE FOO IS IN ONE SEGMENT AND BAR IN THE OTHER.
;;; THE CORRECT WAY TO WRITE THE ABOVE INSTRUCTION IS
;;; 2DIF JRST (X),FOO,BAR
DEFINE 2DIF INST,X,Y
IFN %HISEG+1, 2DIF1 \.-HILOC,HILOC,[X][Y]\N2DIF
IFE %HISEG+1, 2DIF1 \.-FIRSTLOC,FIRSTLOC,[X][Y]\N2DIF
N2DIF==N2DIF+1
INST
TERMIN
;;; A COUPLE OF CROCKS:
;;; [1] THE .CRFON AND .CRFOFF IN ZZD!N INTERACT WITH
;;; THOSE IN THE MACROLOOP MACRO.
;;; [2] THE OFFSETS ALLOW ADDRESSES CONTAINING . IN
;;; THE 2DIF'ED INSTRUCTION (KNOCK PLASTIC).
;;; I.E. THE OFFSET F+L-. IS A HACK SO THAT
;;; ANY .'S IN X OR Y WILL REFER TO THE 2DIF'D
;;; INSTRUCTION AND NOT TO THE PLACE WHERE THE ZZD!N
;;; GETS EXPANDED.
DEFINE 2DIF1 L,F,X,Y,N
.CRFOFF
DEFINE ZZD!N
.CRFON
OFFSET F+L-.
MOVEI T,X
SUBI T,Y
OFFSET 0
.CRFOFF
HRRM T,F+L
TERMIN
.CRFON
TERMIN
;;; THE ZZD MACROS GET EXPANDED IN THE INIT ROUTINE.
] ;END OF IFN D10
DEFINE INTPRO W
PROENT \.-.RL1,W,\NPRO
TERMIN
DEFINE PROENT L,W,N
DEFINE PRO!N
W,,L+.RL1
TERMIN
NPRO==NPRO+1
TERMIN
DEFINE NOPRO ;BEGINS INTERVAL WITH NO INT PROTECTION
INTPRO INTOK
TERMIN
DEFINE SFXPRO ;CODE PROMISES TO RETURN THROUGH AN SFX CELL
INTPRO INTSFX
TERMIN
DEFINE XCTPRO ;FOLLOWING INSTRS MUST BE XCT'D BEFORE INT
INTPRO INTXCT
TERMIN
DEFINE BAKPRO ;MUST BACK UP TO HERE IF INT HAPPENS
INTPRO INTBAK
TERMIN
DEFINE SPECPRO H ;USED A SPECIALIZED PROTECTION ROUTINE
INTPRO H
TERMIN
;;; NO PROTECTION FOR ABSOLUTE LOCATIONS FROM 0 UP TO NEXT INTERVAL
DEFINE PRO0
INTOK,,0
TERMIN
;;; THE PRO MACROS ARE EXPANDED AT PROTB (Q.V.)
SUBTTL ST AND GCST HACKERS
IFN ITS,[
;;; THESE MACROS ACTUALLY FILL IN THE SEGMENT TABLES, FOR ITS ASSEMBLIES
DEFINE $ST SPC,BITS
IFN .-ST-<B!SPC!SG/SEGSIZ>,[
WARN [SEGMENT TABLE PHASE ERROR - TABLE LOC=]\.-ST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ
LOC ST+<B!SPC!SG/SEGSIZ>
]
IFN N!SPC!SG, $ST1 SPC,\N!SPC!SG,BITS
TERMIN
DEFINE $ST1 SPC,N,XBITS
ST.!SPC:
ZZ==0
IRP TYPE,,[LIST,FIXNUM,FLONUM,BIGNUM,SYMBOL,RANDOM,ARRAY]BB,,[LS,FX,FL,BN,SY,RN,SA]
IFN <XBITS>&BB,[
REPEAT N, <XBITS>,,Q!TYPE
ZZ==ZZ+1
]
TERMIN
IFN ZZ-1, WARN [IMPROPER TYPE BITS FOR SPC SPACE: ]\XBITS
TERMIN
;;; THERE ARE NO INITIAL HUNKS!!!
;;; THESE MACROS HAVE THEREFORE NOT BEEN HACKED FOR HUNKS!!!
DEFINE $GCST SPC,LINK,BTBP,BITS
IFSE LINK,L, L!SPC!SG==0
IFN .-GCST-<B!SPC!SG/SEGSIZ>,[
WARN [GCST PHASE ERROR - TABLE LOC=]\.-GCST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ
LOC GCST+<B!SPC!SG/SEGSIZ>
]
IFN N!SPC!SG, $GCST1 \N!SPC!SG,SPC,LINK,BTBP,BITS
TERMIN
DEFINE $GCST1 N,SPC,LINK,BTBP,BITS
GS.!SPC:
REPEAT N,[
ZZ==(BITS)
IFSE BTBP,B, ZZ==ZZ+BTB.←<5-SEGLOG>
.ALSO BTB.==BTB.+BTBSIZ
IFSE LINK,L, ZZ==ZZ+L!SPC!SG←<22-<SEGLOG-5>>
.ALSO L!SPC!SG==.-GCST
ZZ
]
TERMIN
] ;END OF IFN ITS
IFE ITS,[
;;; THIS MACRO MAKES UP THE CODE THAT INITIALIZES THE SEGMENT TABLES
DEFINE 10ST SPC,STENT=[$XM,,QRANDOM]GCENT=0,LINK,BITS
IFN N!SPC!SG,[
MOVEI T,B!SPC!SG
LSH T,-SEGLOG
MOVE TT,[STENT]
REPEAT N!SPC!SG, MOVEM TT,ST+.RPCNT(T)
IFN GCENT,[
MOVSI TT,GCENT
REPEAT N!SPC!SG,[
IFSN BITS,,[
HRRI TT,(AR1)
ADDI AR1,1
] ;END OF IFSN BITS,,
MOVEM TT,GCST+.RPCNT(T)
] ;END OF REPEAT N!SPC!SG
] ;END OF IFN GCENT
IFSN LINK,,[
IFG N!SPC!SG-1,[
HRLI T,-N!SPC!SG+1
DPB T,[SEGBYT,,GCST+1(T)]
AOBJN T,.-1
] ;END OF IFG N!SPC!SG-1
HRRZM T,LINK
] ;END OF IFSN LINK,,
] ;END OF IFN N!SPC!SG
TERMIN
] ;END OF IFE ITS
;;; $<GS>T IN DDT IS GOOD FOR LOOKING AT GCST
GS==<777000,,>\<<1←<22-<SEGLOG-5>>>-1>
;;; FOR FETCHING LINK FIELD WITH A LDB
SEGBYT==<22-<SEGLOG-5>>←14+<22-SEGLOG>←6
SUBTTL EXPUNGE ITS SYMBOLS FROM NON-ITS ASSEMBLY
IFE ITS,[
;;; FOR DEC-10 VERSION WE DON'T WANT TO USE ANY ITS-ONLY SYMBOLS, SO
;;; WE EXPUNGE THEM ALL. THIS MAINLY HELPS TO CATCH INCORRECT CONDITIONALS.
;;; NAMES OF ITS UUOS
EXPUNGE .ACCESS .ARMOFF .ARMOVE .ARMRS .ASSIGN .ATTY
EXPUNGE .BREAK
EXPUNGE .CALL .CBLK .CLOSE .CORE
EXPUNGE .DCLOSE .DCONTIN .DEMON .DESIGN .DIETIME .DISMISS .DISOWN
EXPUNGE .DMPCH .DSTART .DSTEP .DSTOP .DSTRTL .DTTY .DWORD
EXPUNGE .EVAL
EXPUNGE .FDELE .FEED
EXPUNGE .GENSYM .GETLOC .GETSYS .GUN
EXPUNGE .HANG
EXPUNGE .IFSET .IOPDL .IOPOP .IOPUSH .IOT .IOTLSR .IPDP .ITYI .ITYIC
EXPUNGE .LISTEN .LOGOUT .LTPEN
EXPUNGE .MASTER .MTAPE
EXPUNGE .NDIS .NETAC .NETINT .NETS
EXPUNGE .OPEN .OPER
EXPUNGE .PDTIME .POTSET
EXPUNGE .RBTC .RCHST .RDATE .RDATIM .RDSW .RDTIME .REALT .REDEF
EXPUNGE .RESET .REVIVE .RLPDTM .RSYSI .RTIME .RYEAR
EXPUNGE .SETLOC .SETM2 .SETMSK .SHUTDN .SLEEP .STATUS .SUPSET .SUSET .SWAP
EXPUNGE .TRANAD .TRANDL
EXPUNGE .UBLAT .UCLOSE .UDISMT .UINIT .UPISET .USET .UTNAM .UTRAN
EXPUNGE .VALUE .VSCAN .VSTST
;;; NAMES OF .SUSET VARIABLES
EXPUNGE .R40ADDR .S40ADDR .R60H .S60H .RADF1 .SADF1 .RADF2 .SADF2
EXPUNGE .RAIFPIR .SAIFPIR .RAMASK .SAMASK .RAMSK2 .SAMSK2
EXPUNGE .RAPIRQ .SAPIRQ .RAPRC .SAPRC .RBCHN .SBCHN
EXPUNGE .RDF1 .SDF1 .RDF2 .SDF2 .RFLS .SFLS .RIDF1 .SIDF1
EXPUNGE .RIDF2 .SIDF2 .RIFPIR .SIFPIR .RIIFPIR .SIIFPIR
EXPUNGE .RIMASK .SIMASK .RIMSK2 .SIMSK2 .RINTB .SINTB
EXPUNGE .RIOC .SIOC .RIOP .SIOP .RIOS .SIOS
EXPUNGE .RIPIRQC .SIPIRQC .RJNAME .SJNAME .RJPC .SJPC
EXPUNGE .RMARA .SMARA .RMARPC .SMARPC .RMASK .SMASK .RMEMT .SMEMT
EXPUNGE .RMPVA .SMPVA .RMSK2 .SMSK2 .ROPC .SOPC
EXPUNGE .ROPTION .SOPTION .RPICLR .SPICLR .RPIRQC .SPIRQC
EXPUNGE .RPMAP .SPMAP .RRTMR .SRTMR .RRUNT .SRUNT .RSNAM .SSNAM
EXPUNGE .RSV40 .SSV40 .RSV60 .SSV60 .RTTY .STTY
EXPUNGE .RTVCREG .STVCREG .RUIND .SUIND .RUNAME .SUNAME
EXPUNGE .RUPC .SUPC .RUSTP .SUSTP .RUTRP .SUTRP
EXPUNGE .RUUOH .SUUOH .RVAL .SVAL
IFN ITS,[
IFNDEF .IOT,[ ;.IOT IS NORMALLY DEFINED IN ITS ASSEMBLIES
.INSRT SYS:ITS DEFS
.ITSDF
] ;END OF IFNDEF .IOT
] ;END OF IFN ITS
IFN D10,[
IFNDEF DAEMON,[ ;DAEMON IS NORMALLY DEFINED IN DEC-10 ASSEMBLIES
ZZW==CALL ;IF PULLING IN TOPS-10 SYMBOL DEFINITIONS, MUST REMEMBER
$INSRT SYS:DECDFS
.DECDF
EXPUNGE CALL ;THAT "CALL" IS A LISP UUO, AS WELL AS A MONITOR CALL
CALL==ZZW
] ;END OF IFNDEF DAEMON
EXPUNGE INIT
HALT=JRST 4,
EQUALS .VALUE HALT
] ;END OF IFN D10
] ;END OF IFE ITS
SUBTTL DEFINITIONS OF BITS AND THINGS FOR THE TTY VARIABLES.
IFN ITS,[
;;; INITIAL TTY STATUS IS AS FOLLOWS:
;;; ACTIVATION CHARS:
;;; ↑@-↑L, ↑N-↑Z, ↑\-↑←, SPACE, < > ( ) [ ] { } RUBOUT
;;; INTERRUPT CHARS:
;;; ↑@-↑H, ↑K, ↑L, ↑N-↑Z, ↑\-↑←, SPACE
;;; SPACE AND BACKSPACE OUTPUT IN IMAGE MODE, ALL OTHERS IN ASCII.
;;; ALL CHARS ECHO IN PI MODE (ECHO WHEN TYPED).
DEFINE %STTY X,Y
STTY!X==<STTY!X←6>+%TG<Y>
TERMIN
;;; IMG => IMAGE
;;; PIE => PI ECHO (ECHO WHEN TYPED),
;;; ACT => ACTIVATION CHARACTER
;;; INT => INTERRUPT WHEN TYPED
STTYW1==0 ;TTYST1 FOR (STATUS LINMODE) = NIL
%STTY W1,PIE+ACT+INT ;[ ;↑@ ↑A-↑F ↑K-↑L ↑N-↑R ↑T-↑Z ↑] ↑\ ↑↑ ↑←
%STTY W1,PIE ;A-Z (UPPER CASE), a-z (LOWER CASE)
%STTY W1,PIE ;0-9
%STTY W1,PIE ;! " # $ % & ' , . : ; ? @ \ ` | }
%STTY W1,PIE ;* + - / = ↑ ←
%STTY W1,PIE+ACT ;< > ( ) [ ] { }
STTYW2==0 ;TTYST2 FOR (STATUS LINMODE) = NIL
%STTY W2,PIE+ACT+INT ;↑G ↑S
%STTY W2,PIE+ACT ;↑J ↑I
%STTY W2,PIE ;ALTMODE
Q% %STTY W2,PIE ;↑M
Q$ %STTY W2,PIE+ACT ;↑M (ACT FOR READLINE FUNCTION)
%STTY W2,ACT ;RUBOUT
Q% %STTY W2,IMG+PIE+ACT+INT ;SPACE ↑H
Q$ %STTY W2,IMG+PIE+ACT ;SPACE ↑H
STTYL1==0 ;TTYST1 FOR (STATUS LINMODE) = T
%STTY L1,PIE+ACT+INT ;[ ;↑@ ↑A-↑F ↑K-↑L ↑N-↑R ↑T-↑Z ↑] ↑\ ↑↑ ↑←
%STTY L1,PIE ;A-Z (UPPER CASE), a-z (LOWER CASE)
%STTY L1,PIE ;0-9
%STTY L1,PIE ;! " # $ % & ' , . : ; ? @ \ ` | }
%STTY L1,PIE ;* + - / = ↑ ←
%STTY L1,PIE ;< > ( ) [ ] { }
STTYL2==0 ;TTYST2 FOR (STATUS LINMODE) = T
%STTY L2,PIE+INT ;↑G ↑S
%STTY L2,PIE ;↑J ↑I
%STTY L2,PIE ;ALTMODE
%STTY L2,PIE+ACT ;↑M
%STTY L2,ACT ;RUBOUT
Q% %STTY L2,IMG+PIE+INT ;SPACE ↑H
Q$ %STTY L2,IMG+PIE ;SPACE ↑H
STTYA1==0 ;TTYST1 FOR ALLOC
%STTY A1,ACT ;[ ;↑@ ↑A-↑F ↑K-↑L ↑N-↑R ↑T-↑Z ↑] ↑\ ↑↑ ↑←
%STTY A1,PIE+ACT ;A-Z (UPPER CASE), a-z (LOWER CASE)
%STTY A1,PIE+ACT ;0-9
%STTY A1,PIE+ACT ;! " # $ % & ' , . : ; ? @ \ ` | }
%STTY A1,PIE+ACT ;* + - / = ↑ ←
%STTY A1,PIE+ACT ;< > ( ) [ ] { }
STTYA2==0 ;TTYST2 FOR ALLOC
%STTY A2,PIE+IMG+ACT ;↑G ↑S
%STTY A2,ACT ;↑J ↑I
%STTY A2,PIE+ACT ;ALTMODE
%STTY A2,ACT ;↑M
%STTY A2,ACT ;RUBOUT
%STTY A2,PIE+ACT ;SPACE ↑H
] ;END OF IFN ITS
;;@ END OF MACS 45
SA% LRCT==210 ;SPACE SUFFICIENT FOR CHARS
SA$ NASCII==1000
SA$ LRCT==1010
IFN ITS, PAGLOG==:12 ;LOG2 OF PAGE SIZE (DAMN WELL BETTER BE 12 FOR ITS!!!
.ELSE PAGLOG==:11 ; SOME CODE ASSUMES IT WILL BE 11 OR 12)
LONUM==400 ;MINIMUM MAGNITUDE OF LOWEST NEGATIVE INUM
HINUM==1000 ;MINIMUM MAGNITUDE OF LARGEST POSITIVE INUM
;SOME CODE ASSUMES HINUM IS AT LEAST 777
;MUCH CODE ASSUMES HINUM IS AT LEAST 177 (FOR ASCII CHARS)
;;; IF1
;;; ALL FLAGS WHICH ARE NON-ZERO MUST BE ONES: SOME CONDITIONAL
;;; ASSEMBLY DOES ARITHMETIC WITH THEM (E.G. FASLOAD; SEE LDFNM2)
IRP FOO,,[ITS,D10,TENEX,ML,MOBIOF,BIGNUM,EDFLAG,FUNAFL
NEWRD,NSTAT,QIO,JOBQIO,USELESS]
IFN FOO, FOO==:1
.ELSE FOO==:0
TERMIN ;USE OF ==: PREVENTS CHANGING THEM
MEMORY==:<1,,0> ;SIZE OF MEMORY!!!
PAGSIZ==:1←PAGLOG ;PAGE SIZE
PAGMSK==:<777777←PAGLOG>&777777 ;MASKS ADDRESSES TO PAGE BOUNDARY
PAGKSM==:PAGMSK#777777 ;MASKS WORD ADDRESS WITHIN PAGE
NPAGS==:MEMORY/PAGSIZ ;NUMBER OF PAGES IN MEMORY
;;; IF1
IFL SEGLOG-7, WARN [SEGLOG=]\SEGLOG,[ IS TOO SMALL (I ASSUME SEGLOG=10)]
.ALSO SEGLOG==10
IFG SEGLOG-PAGLOG, WARN [SEGLOG=]\SEGLOG,[ IS TOO LARGE (I ASSUME SEGLOG=]\PAGLOG,[)]
.ALSO SEGLOG==PAGLOG
SEGLOG==:SEGLOG ;THIS IS THE FINAL VALUE
SEGSIZ==:1←SEGLOG ;SEGMENT SIZE
SEGMSK==:<777777←SEGLOG>&777777 ;MASKS ADDRESSES TO SEGMENT BOUNDARY
SEGKSM==:SEGMSK#777777 ;MASKS WORD ADDRESS WITHIN SEGMENT
NSEGS==:MEMORY/SEGSIZ ;NUMBER OF SEGMENTS IN MEMORY
BTBSIZ==:SEGSIZ/40 ;SIZE OF BIT BLOCKS (ENOUGH BITS FOR A SEGMENT, 40 PER WORD)
SGS%PG==:NSEGS/NPAGS ;NUMBER OF SEGMENTS PER PAGE
BTSGGS==1 ;GUESS AT THE NUMBER OF INITIAL BIT SEGMENTS
IFN ITS,[
ALPDL==4*PAGSIZ ;DEFAULT TOTAL PDL SIZES
ALFXP==4*PAGSIZ
ALFLP==1*PAGSIZ
ALSPDL==2*PAGSIZ
] ;END OF IFN ITS
IFN D10,[
ALFXP==SEGSIZ ;DEFAULT TOTAL PDL SIZES
ALFLP==SEGSIZ
ALPDL==3000
ALSPDL==1400
] ;END OF IFN D10
DEFINE FUMBLIFY LL
IRP TP,,[FFS,FFX,FFL,FFB,FFY,FFH,FFA,PDL,SPDL,FXP,FLP]AL,,[LL]
ZZZ==.IRPCNT
IRP M,,[MIN,MAX]A,,[AL]
M!!TP==A
IFSE M,MAX, IFL ZZZ-6, IFL A-SEGSIZ, M!!TP==SEGSIZ
TERMIN
TERMIN
TERMIN
FUMBLIFY [[0.25,40000],[0.2,14000],[0.15,2*SEGSIZ],[3*SEGSIZ/4,2*SEGSIZ],[SEGSIZ/2,6000],[0,SEGSIZ],[40,SEGSIZ],[200,1400],[100,1400],[200,1000],[20,200]]
FUMBLIFY [[.25,40000],[.25,3000],[.25,SEGSIZ],[.25,SEGSIZ],[SEGSIZ/2,3*SEGSIZ],[0,SEGSIZ],[40,SEGSIZ],[200,1400],[100,1400],[200,1000],[20,200]]
BG% MAXFFB==0
BG% MINFFB==0
;;; BIT POSITIONS IN SEGMENT TABLE WD LH
;;; MUST BE DEFINED BEFORE SKOTT MACRO (Q.V.) CAN BE USED
;;; SEE ALSO PSYMTT
IRPS TP,,[LS=$FS=$FX=$FL=BN=SY=SA=VC=$FXP=$FLP=$XM=$NXM=PUR=HNK=]
TP==1←<21-.IRPCNT>
IFE TP, WARN [TOO MANY ST BITS - TP IS ZERO]
TERMIN
FX==$FX\$FXP
FL==$FL\$FLP
RN==$XM\$NXM
NTYPES==:5+BIGNUM+HNKLOG+1 ;# DATA TYPES, PLUS RANDOM
;;; IF1
;;; ********** INTERRUPT BITS **********
IFN ITS,[
;;; LISP SETS ITS INTERRUPT MASK (.MASK USET VARIABLE) ONLY FROM
;;; THE CONTENTS OF LOCATION INTMSK, WHICH INITIALLY CONTAINS ITSMSK.
;;; DEPOSITING DBGMSK THERE BEFORE STARTUP DISABLES ALL INTERRUPTS
;;; EXCEPT TTY AND PDL OVERFLOW, SO THAT DDT WILL TRAP ILOP, MPV, ETC.
IB.ALARM==200000,, ; REAL TIME CLOCK (ALARM CLOCK)
IB.TIMER==100000,, ; RUN TIME CLOCK
IB.PARITY==1000,, ;+ PARITY ERROR
IB.FLOV==400,, ; FLOATING OVERFLOW
IB.PURE==200,, ;+ PURE PAGE TRAP (WRITE INTO READ-ONLY)
IB.PCPURE==100,, ;+ PURE INSTRUCTION FETCH FROM IMPURE
IB.SYSUUO==40,, ;+ SYS UUO TRAP
IB.AT3==20,, ; ARM TIP BREAK 3
IB.AT2==10,, ; ARM TIP BREAK 2
IB.AT1==4,, ; ARM TIP BREAK 1
IB.DEBUG==2,, ; SYSTEM BEING DEBUGGED
IB.RVIOL==1,, ;+ RESTRICTION VIOLATION (?)
IB.CLI==400000 ; CORE LINK INTERRUPT
IB.PDLOV==200000 ; PDL OVERFLOW
IB.LTPEN==100000 ; LIGHT PEN INTERRUPT
IB.MAR==40000 ;+ MAR INTERRUPT
IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION
IB.SCLK==10000 ; SLOW CLOCK TICK (.5 SEC)
IB.1PROC==4000 ;* SINGLE INSTRUCTION PROCEED
IB.BREAK==2000 ;* .BREAK EXECUTED
IB.ILAD==1000 ;+ ILLEGAL USER ADDRESS
IB.IOC==400 ;+ I/O CHANNEL ERROR
IB.VALUE==200 ;* .VALUE EXECUTED
IB.DOWN==100 ; SYSTEM GOING DOWN OR BEING REVIVED
IB.ILOP==40 ;+ ILLEGAL INSTRUCTION OPERATION
IB.DMPV==20 ;+ DISPLAY MEMORY PROTECTION VIOLATION
IB.AROV==10 ; ARITHMETIC OVERFLOW
IB.42BAD==4 ;* BAD LOCATION 42
IB.C.Z==2 ;* ↑Z TYPED WHEN THIS JOB HAD TTY
IB.TTY==1 ; INTERRUPT CHAR TYPED ON TTY
Q% ITSMSK=IB<TTY+ILOP+IOC+MPV+PDLOV+TIMER+ALARM+PURE>
Q% DBGMSK=IB<TTY+PDLOV>
] ;END OF IFN ITS
IFN D10,[
IB.PDLOV==200000 ; PDL OVERFLOW
IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION
] ;END OF IFN D10
;;; IF1
;;; ********** I/O CHANNEL ASSIGNMENTS **********
IFE QIO,[
ERRC==0 ;ERROR MESSAGE CHANNEL
TYIC==1 ;TTY INPUT
TYOC==2 ;TTY OUTPUT
UTIC==3 ;UREAD ("U-TAPE") INPUT (↑Q)
UTOC==4 ;UWRITE OUTPUT (↑R)
LPTC==5 ;LINE PRINTER (↑B) OUTPUT
DSIC==6 ;DISK CHANNEL (USED FOR BOTH INPUT AND OUTPUT)
IFN MOBIOF,[
IPLC==7 ;INTERPRETIVE PLOTTER
VIDC==10 ;VIDISECTOR
NVDC==11 ;FAKE VIDISECTOR
IMXC==12 ;MULTIPLEXER INPUT
OMXC==13 ;MULTIPLEXER OUTPUT
BVDC==14 ;BLOCK VIDI INPUT
DISC==15 ;DISPLAY OUTPUT
SIXC==16 ;PDP-6 CHANNEL (DISPLAY SLAVE)
FTVC==BVDC ;CANT BE USING BOTH FAKE TV AND BLOCK VIDI INPUT
] ;END OF IFN MOBIOF
IFN D10,[
DELC==7 ;RANDOM I/O CHANNEL FOR DEC-10
] ;END OF IFN D10
10% IFE MOBIOF, NOFCH==7 ;NUMBER OF I/O CHANNELS
10% IFN MOBIOF, NOFCH==17
10$ NOFCH==10
] ;END OF IFE QIO
;;; PAGE 376 IS RESERVED FOR COPYING (SEE IP1), AND 377 FOR DISUSE.
;;; (THE DISUSE AS TO DO WITH AN OLD HARDWARE BUG IN BLT.)
;;; ON AI, PAGE 375 IS FOR MAPPING PAGE 0 OF THE DISPLAY SLAVE.
10% Q% P6=MEMORY-3*PAGSIZ ;PAGE 0 OF PDP6 SLAVE IS MAPPED INTO PDP-10 MEMORY
] ;END OF IF1
SUBTTL FIRST LOCATIONS, UUO AND INTERRUPT VECTORS
;IFE <ITS+TENEX>*USELESS, NPGTPS==0
IFE 0, NPGTPS==0
TOPN==0
BOTN==0
.XCREF TOPN BOTN
IFN ITS+TENEX,[
NPURTR==0
Q$ NIOCTR==0
.XCREF PURTR1 NPURTR NIOCTR
] ;END OF IFN ITS+TENEX
N2DIF==0
NPRO==0+1 ;NUMBER OF INTERRUPT PROTECTION REGIONS
;NOTE DEFN OF PRO0 IN MACS FILE
.XCREF NPRO
IFN D10,[
.DECTWO ;DEC TWO-SEGMENT RELOC OUTPUT
%LOSEG==-1 ;INITIALLY START IN LOW SEGMENT
%HISEG==0 ;START AT 0 RELATIVE TO HIGH SEG ORIGIN
] ;END OF IFN D10
IFN ITS, IFDEF .SBLK, .SBLK ;EVENTUALLY FLUSH "IFDEF .SBLK"
.YSTGWD ;STORAGE WORDS ARE OKAY NOW
FIRSTLOC:
IFN D10,[
HILOC==.+400000 ;HISEG STARTS AT 400000
;;; FOR DEC-10, FIRSTLOC AS LOADED WITH RELOCATION MUST BE
;;; STDLO+M*SEGSIZ
;;; AND SIMILARLY HILOC WHEN LOADED MUST BE
;;; STDHI+N*SEGSIZ
;;; FOR INTEGRAL M AND N. INIT WILL ENFORCE THIS IN ORDER
;;; TO PRESERVE SEGMENT BOUNDARIES CORRECTLY.
;;; CURSTD IS THE STDXX FOR WHICHEVER IS THE CURRENT SEGMENT.
STDLO==140 ;SIZE OF JOB DATA AREA
STDHI==10 ;VESTIGIAL JOB DATA AREA
CURSTD==STDLO .SEE $LOSEG
] ;END OF IFN D10
IFN ITS,[
STDLO==0
STDHI==0
CURSTD==0
]
10% BZERSG==0 ;BEGINNING OF "ZERO" SEGMENT(S)
10$ BZERSG==FIRSTLOC-STDLO
LOC 41
JSR UUOH ;UUO HANDLER
10X WARN [TENEX INTERRUPT VECTOR?]
LOC FIRSTLOC
JRST GOINIT
LISPSW: ALLOC ;ALLOC CLOBBERS TO BE "LISP"
IFN ITS,[
TWENTY==:20 ;VARIOUS PLACES OFFSET FROM TWENTY ARE USED BY DDT
THIRTY==:TWENTY+10 ;RECALL THAT THE LEFT HALF OF .40ADDR IS THE ".20ADDR"
;;; ADDRESSES IN THE 20 BLOCK, SWIPED FROM DDT ORDER
;;; 25 HOLDS "." DURING A USER TYPEOUT INSTRUCTION
;;; 26 CONDITIONAL BREAKPOINT INSTRUCTION
;;; 27-30 .BREAK 16,'S FOR RETURNING FROM 26
;;; 31 INSTRUCTION FOR BREAKPOINT WHICH DIDN'T BREAK
;;; 32-33 JRST'S TO PROGRAM FROM 31, OR DATA FOR INSTRUCTION IN 31
;;; 34 INSTRUCTION BEING ≠X'D
.SEE MEMERR
.SEE UUOGL2
;;; 35-36 .BREAK 16,'S FOR RETURNING FROM 34
.SEE $XLOST
.SEE UUOGL2
;;; 37 HOLDS ≠Q DURING A USER TYPEOUT INSTRUCTION
.SEE PSYM1
FORTY: 0 ;.40ADDR USER VARIABLE POINTS HERE
JSR UUOGLEEP ;SYSTEMIC UUO HANDLER
Q% JSR INT ;SYSTEMIC INTERRUPT HANDLER
Q$ -LINTVEC,,INTVEC ;SYSTEMIC INTERRUPT HANDLER
;;; THAT'S SYSTEMIC, NOT NECESSARILY SYSTEMATIC!!!
;;; ITS PASSES THE BUCK TO THE USER ON UUO'S 0 AND 50-77.
;;; THEY TRAP THROUGH THE .40ADDR, NOT NECESSARILY 40;
;;; SINCE LISP TREATS THESE AS ERRORS, WE CAN AFFORD TO SAVE
;;; THE JPC AND OTHER GOODIES HERE.
UUOGLEEP: 0
.SUSET [.RJPC,,JPCSAV]
JRST UUOGL1
JPCSAV: 0
] ;END OF IFN ITS
SUBTTL SFX HACKERY
;;; SFX MACRO TELLS WHERE A LONG PIECE OF SEMI-CRITICAL (MAY BE QUIT
;;; OUT OF, BUT MUST NOT PERMIT USER INTERRUPTS IN) CODE MAY BE MUNGED
;;; IF INTERRUPTED IN THE MIDDLE SO THAT WHEN DONE IT WILL RETURN TO
;;; THE INTERRUPT HANDLER. SUCH CODE INCLUDES ARRAY SUBSCRIPT
;;; COMPUTATIONS (SINCE AN INTERRUPT COULD DISPLACE THE ARRAY)
;;; AND ALL CODE WHICH MODIFIES THE SPECIAL PDL.
NSFC==0 ;COUNTER FOR MACRO SFX
.XCREF NSFC
IFN D10,[
DEFINE SFX A/
SFSTO \.-FIRSTLOC,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
FIRSTLOC+PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN D10
IFN ITS,[
DEFINE SFX A/
SFSTO \.,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN ITS
;;; THE ZZM AND ZZN MACROS ARE EXPANDED AT SFXTBL (Q.V.)
;;; **** ALL USES OF THE SFX MACRO MUST APPEAR ON THIS PAGE ****
SFXPRO
UNBND2: MOVE TT,(SP)
MOVEM TT,SPSV ;ABOUT LOADING TT WITH SPSV, SEE UNBIND
MOVE TT,UNBND3
SFX POPJ P,
ABIND3: PUSH SP,SPSV
SFX POPJ P,
SETXIT: SUB SP,R70+1
SFX JRST (T)
SPECX: PUSH SP,SPSV
SFX JRST (T)
AYNVSFX: ;XCT'ED BY AYNVER
SFX %WTA (D)
1DIMS: JSP T,AYNV1 ;1-DIM S-EXP ARRAYS COME HERE
ARYGET: ROT R,-1 ;COMMON S-EXP ARRAY ACCESS ROUTINE
ADDI TT,(R)
ARYGT4: JUMPL R,ARYGT8
HLRZ A,(TT)
SFX POPJ P,
ARYGT8: HRRZ A,(TT)
SFX POPJ P,
1DIMF: JSP T,AYNV1 ;1-DIM FULLWORD ARRAYS COME HERE
ANYGET: ADDI TT,(R) ;COMMON FULLWORD ARRAY ACCESS ROUTINE
MOVE TT,(TT)
SFX POPJ P,
NOPRO
SPSV: 0 ;IMPORTANT TO SPECPDL BINDINGS
Q% .SEE INTW0
Q$ .SEE IWAIT
;;; **** THERE MUST BE NO MORE USES OF THE MACRO SFX BEYOND HERE ****
EXPUNGE SFX SFSTO
SUBTTL INTERRUPT FLAGS AND VARIABLES
;;; INTFLG INDICATES WHETHER IN INTERRUPT IS PENDING:
;;; 0 => NO INTERRUPT
;;; -1 => USER INTERRUPT PENDING (STACKED IN INTAR)
;;; -2 => ↑X QUIT PENDING, DON'T RESET TTY
;;; -3 => ↑G QUIT PENDING, DON'T RESET TTY
;;; -6 => ↑X QUIT PENDING, DO RESET TTY
;;; -7 => ↑G QUIT PENDING, DO RESET TTY
INTFLG: 0
;;; MAY NOT ↑G/↑X QUIT OR ALLOW USER INTERRUPTS IF NOQUIT NON-ZERO
;;; NON-ZERO IN LH MEANS GC IN PROGRESS; IMPLIES
;;; PDL POINTERS AND NIL MAY BE CLOBBERED
;;; NON-ZERO ONLY IN RH MEANS PDL POINTERS AND NIL ARE OK
NOQUIT: 0
;;; MAY NOT ALLOW "REAL TIME" INTERRUPTS (CLOCK AND TTY) WHEN
;;; UNREAL IS NON-ZERO. MUNGED BY THE FUNCTION NOINTERRUPT.
;;; 0 => ALL INTERRUPTS OKAY
;;; -1 => NO INTERRUPTS OKAY
;;; 'TTY => ALARMCLOCK OKAY, TTY NOT OKAY
UNREAL: 0
IFE QIO,[
QITC: 0 ;PLACES FOR VARIOUS INTERRUPT-TYPE GUYS TO SAVE ACS
QITD: 0
QITR: 0
] ;END OF IFE QIO
Q$ ERRSVD: 0 .SEE ERRBAD
;;; INTERRUPT MASK IS ALWAYS INITIALIZED FROM THIS WORD. THUS
;;; DEPOSITING INTO IT BEFORE STARTUP CAN AID DEBUGGING (CF. DBGMSK)
10% INTMSK: ITSMSK ;INTERRUPT MASK USED ON STARTUP
10% Q$ INTMS2: ITSMS2 ;MASK WORD 2
10$ SJBENB: 630000 ;INTERRUPT ENABLE MASK
LFAKP==5 ;MUST BE LONG ENOUGH FOR USES BY
LFAKFXP==6 ; PDLOV, ERINIT, AND PURIFY
FAKP: BLOCK LFAKP ;FAKE REGPDL, FOR USE BY PDLOV AND ERINIT
FAKFXP: BLOCK LFAKFXP ;FAKE FIXPDL, FOR USE BY PDLOV AND ERINIT
IFE QIO,[
WAITFL: 0 ;NON-ZERO => INTWAIT IS LETTING AN SFXPRO'ED ROUTINE FINISH
WAITA: 0 ;A TEMPORARY FOR INTWAIT
WAITD2: 0 ;USED BY WAIT TO SAVE .DF2
] ;END OF IFE QIO
;;; IF NON-ZERO, THIS CONTAINS THE ADDRESS OF A USER-SUPPLIED
;;; INTERRUPT PROCESSOR. THE LISP SYSTEM INTERRUPT HANDLER
;;; WILL GIVE IT ANY INTERRUPT LISP DOESN'T PROCESS ITSELF. SEE INT0.
UPIINT: 0
SUBTTL ENTRIES TO VARIOUS ROUTINES CALLED BY JSR
UISTAK: 0 ;STACK UP (ACTUALLY, QUEUE) A USER INTTERRUPT
JRST UISTK1
IFE QIO,[
INTWAIT: 0 ;CHECK TO SEE IF USER INTERRUPT OKAY NOW.
JRST INTW0
SPWR: 0 ;"SPECPDL WINNING RETURN" USED BY INTWAIT TO
JRST SPWR0 ; KEEP SP CONSISTENT. SEE ALSO THE SFX MACRO.
CNTROL: 0 ;PROCESS A CONTROL CHARACTER.
JRST CNTRL1 ;ASCII CODE IS IN ACCUMULATOR A.
IFE D10,[
PDLHAK: 0 ;FIGURE OUT WHICH PDL OVERFLOWED AND FIX IT.
JRST PDLH0 ;IF A NON-ZERO, HAS ADDRESS OF PDL POINTER.
] ;END OF IFE D10
] ;END OF IFE QIO
GCRSR: 0 ;GC RESTORE. CLEANS UP JUST BEFORE AN
JRST GCRSR0 ; ABNORMAL EXIT (GCEND IS NORMAL EXIT).
IFE D10,[
PDLSTH: 0 ;"PDL ST HACK". GETS A NEW PAGE FOR A PDL,
JRST PDLST0 ; AND UPDATES ST AND GCST APPROPRIATELY.
] ;END OF IFE D10
IFN MOBIOF,[
CLZDIS: 0 ;CLOSE THE DIS DEVICE
JRST CLZDS1
DISLEEP: 0 ;SLEEP AND WAIT FOR DISPLAY SLAVE
JRST DISLP1
DISLP2: 0 ;A COUNTER FOR WAITING OUT REQUESTS
] ;END OF IFN MOBIOF
IFN QIO,[
SUBTTL NEWIO I/O CHANNEL ALLOCATION TABLE
;;; ENTRIES:
;;; 1.1-2.9 => ADDRESS OF FILE ARRAY SAR
;;; IF AN ENTRY IS NON-ZERO BUT ITS FILE ARRAY SAR'S
;;; TTS.CL BIT IS SET, THE CHANNEL MAY BE DE-ALLOCATED.
;;; THIS ORDINARILY HAPPENS ONLY ON A QUIT OUT OF $OPEN.
;;; CHANNEL 0 (TMPC) IS PERMANENTLY LOCKED FOR USE OF THE ERR
;;; DEVICE, FOR UPROBE, ETC. NOTE THAT ITS PUTS .OPEN
;;; AND .CALL FAILURE CODES ON CHANNEL 0 ARBITRARILY.
LCHNTB==20
CHNTB:
OFFSET -.
TMPC:: 400000,,NIL ;FIXED TEMPORARY CHANNEL
IFGE LCHNTB-., BLOCK LCHNTB-.
.ELSE WARN [TOO MANY FIXED I/O CHANNELS]
OFFSET 0
;;; DEC-10 I/O BUFFER HEADERS (MUST REMAIN FIXED IN CORE)
IFN D10, REPEAT LCHNTB, CONC BFHD,\.RPCNT,: BLOCK 3
DPAGEL: 60. ;INITIAL DEFAULT PAGEL
DLINEL: 70. ;INITIAL DEFAULT LINEL
IFN JOBQIO,[
LJOBTB==10 ;EIGHT INFERIOR PROCEDURES
JOBTB: BLOCK LJOBTB
] ;END OF IFN JOBQIO
;;; IFN QIO
SUBTTL INITIAL TTY INPUT FILE ARRAY
-F.GC,,TTYIF2 ;GC AOBJN POINTER
TTYIF1: JSP TT,1DIMS
TTYIFA
0 ;CAN'T ACCESS
TTYIF2:
OFFSET -.
FI.EOF:: NIL ;EOF FUNCTION (??)
FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS
FI.BBF:: NIL ;BUFFERED BACK FORMS
TI.BFN:: QTTYBUF ;PRE-SCAN FUNCTION
FT.CNS:: TTYOFA ;ASSOCIATED TTY OUTPUT FILE
BLOCK 3
F.MODE:: FBT<CM>,,2 ;MODE (ASCII TTY IN SINGLE)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
F.DEV:: SIXBIT \TTY\ ;DEVICE
F.SNM:: 0 ;SNAME/PPN (FILLED IN)
F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
F.FN2:: SIXBIT \INPUT\ ;FILE NAME 2
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
F.FPOS:: -1 ;FILEPOS
TI.ST1:: STTYW1 ;TTYST1
TI.ST2:: STTYW2 ;TTYST2
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
0 ;UNUSED
0 ;UNUSED
BLOCK 6
BLOCK 10
;INTERRUPT FUNCTIONS
FB.BUF::
NIL,,NIL ;↑@ ↑A (SETQ ↑A T)
QCN.BB,,IN0+↑C ;↑B ↑B-BREAK ↑C GC STAT OFF
IN0+↑D,,NIL ;↑D GC STAT ON ↑E
NIL,,IN0+↑G ;↑F ↑G HARD QUIT
REPEAT 3, NIL,,NIL ;↑H-↑M (FORMAT EFFECTORS)
NIL,,NIL ;↑N ↑O
NIL,,NIL ;↑P ↑Q
IN0+↑R,,IN0+↑W ;↑R UWRITE ON? ↑S ↑W INT, ↑V MACRO
IN0+↑T,,NIL ;↑T UWRITE OFF?↑U
IN0+↑V,,IN0+↑W ;↑V TTY ON ↑W TTY OFF
IN0+↑X,,NIL ;↑X SOFT QUIT ↑Y
IN0+↑Z,,NIL ;↑Z GO TO DDT ≠ <ALTMODE>
REPEAT 62, NIL,,NIL ;ALL OTHERS
OFFSET 0
IFN .-TTYIF2-ATIC.SZ, WARN [WRONG LENGTH TTYIF2 (IS ]\.-TTYIF2,[, SHOULD BE ]\ATIC.SZ,[)]
;;; IFN QIO
SUBTTL INITIAL TTY OUTPUT FILE ARRAY
-F.GC,,TTYOF2 ;GC AOBJN POINTER
TTYOF1: JSP TT,1DIMS
TTYOFA
0 ;MAY NOT ACCESS
TTYOF2:
OFFSET -.
FO.EOP:: QTTYMOR ;END OF PAGE FUNCTION
BLOCK 7
F.MODE:: FBT<CM>,,3 ;MODE (ASCII TTY OUT SINGLE) (FBT<SA+CP> FILLED IN)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
F.DEV:: SIXBIT \TTY\ ;DEVICE NAME
F.SNM:: 0 ;SNAME/PPN (FILLED IN)
F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
F.FN2:: SIXBIT \OUTPUT\ ;FILE NAME 2
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
F.FPOS:: -1 ;FILEPOS
TO.TYP:: 0 ;TTY TYPE (FILLED IN)
ATO.LC:: 0 ;LAST CHAR SWITCH
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
FO.LNL:: 71. ;LINEL
FO.PGL:: 200000,, ;PAGEL
BLOCK 6
OFFSET 0
IFN .-TTYOF2-ATOC.SZ, WARN [WRONG LENGTH TTYOF2]
] ;END OF IFN QIO
SUBTTL SUPER-WRITABLE STUFF - MUST BE SAVED UPON USER INTERRUPT
;;; DONT ALLOW USER INTERRUPTS WHILE:
;;; 1) NOQUIT IS NON-ZERO - THIS PROTECTS GC,
;;; RETSP, SUBLIS, AND OTHERS.
;;; 2) INHIBIT IS NON-ZERO - THIS PROTECTS
;;; MANY AREAS OF SEMI-CRITICAL CODE.
;;; (CF. LOCKI AND UNLOCKI MACROS)
SWS==.
IFE QIO,[
INT: 0
IPCLOK: 0 ;PC LOCATION AT TIME OF INTERRUPT
10% JRST INT0
INTSV: 0 ;INTERRUPT REGISTER SAVED
RDOBCT: 0 ;STALLMAN'S HAC TO STOP RDIN0 WHILE READING FROM TAPE
] ;END OF IFE QIO
IFN QIO,[
;;; INTERRUPT PDL
;;; EACH ENTRY HAS FIVE WORDS PUSHED BY THE SYSTEM, PLUS AC F:
LIPSAV==:6 ;LENGTH OF CRUD PUSHED BY INTERRUPT
IPSWD1==:-5 ;WORD ONE (.PIRQC) INTERRUPTS TAKEN
IPSWD2==:-4 ;WORD TWO (.IFPIR) INTERRUPTS TAKEN
IPSDF1==:-3 ;SAVED .DF1
IPSDF2==:-2 ;SAVED .DF2
IPSPC==:-1 ;SAVED PC
IPSF==:0 ;SAVED ACCUMULATOR F
MXIPDL==4 ;MAX SIMULTANEOUS INTERRUPTS
; (CALCULATED FROM THE DEFER WORDS
; IN THE INTERRUPT VECTOR:
; 1 MISCELLANEOUS
; 2 PDL OVERFLOW
; 1 MEMORY ERROR/ILLEGAL OP
LINTPDL==LIPSAV*<MXIPDL+1> .SEE PDLOV
INTPDL: -LINTPDL,,INTPDL .SEE INTVEC
BLOCK LINTPDL
] ;END OF IFN QIO
;;; THE FOLLOWING STUFF IS SAVED WHEN AN "ERRSET FRAME" IS CREATED.
;;; NOT ONLY ERRSET, BUT ALSO CATCH AND READ NEED TO DO THIS.
;;; INTERPRETED PROGS CREATE A SORT OF HALF-ASSED FRAME.
;;; BEWARE! THE COMPILER DEPENDS ON KNOWING THE LENGTH OF
;;; THE ERRSET FRAME AS A CONSTANT PARAMETER.
ERRTN: 0 ;PDL RESTORATION FOR ERRSET
CATRTN: 0 ;PDL RESTORATION FOR CATCH OF A THROW
EOFRTN: 0 ;PDL RESTORATION ON E-O-F TRAPOUT
PA4: 0 ;PDL RESTORATION ON GO OR RETURN
INHIBIT: 0 ;NON-ZERO => INHIBIT (DELAY) USER INTERRUPTS
ERRSW: -1 ;0 MEANS NO PRINT ON ERROR DURING ERRSET
Q% RRDF: -1 ;LEVEL OF READ: -1=>NONE, 0=>SIMPLE, 1=>RECURSIVE
Q$ BFPRDP: 0 ;LH: FUNCTION WHICH WANTS TTY PRE-SCAN
; (READ, READLINE)
; TYI FOR ACTIVATION AND CURSORPOS
; CLEVERNESS, BUT NO PRE-SCAN
; NIL FOR NO CLEVERNESS AT ALL
;RH: -1 IF WITHIN READ
CATID: NIL ;CATCH IDENTIFICATION TAG
LEP1==.-ERRTN ;***** LENGTH OF SOME OF ERRSET PUSH
.SEE ERSTP
UIRTN: 0 ;NON-ZERO => PDL LOC OF MOST RECENT USER INT FRAME
.SEE UINT0
RSXTB: (A) ;POINTER TO READ SYNTAX TABLE, INDEXED BY A
GCD.A: .SEE GCDBB
PNMK1: .SEE PDLNMK ;SAVE TT
UNBND3: .SEE UNBIND ;SAVE TT
SIXMK2: 0 .SEE SIXMAK
SAVMAR: .SEE SUSP14 ;NEEDN'T BE IN SWS, BUT WHO CARES?
GCD.B: .SEE GCDBB
AUNBD: .SEE AUNBIND ;SAVES D FOR AUNBIND
EXP.S: .SEE EXP ;REMEMBERS SIGN OF ARG
ATAN.S: .SEE ATAN ;SAVES SIGNS OF ARGS <X,,Y>
UNMTMP: ;UNAME TEMP
FPTEM: ;PSYM WANTS THIS TO BE SAME AS PCNT!!!
IFLT9: .SEE IFLOAT ;D SAVED HERE
EQLP: 0 ;PDL POINTER UPON ENTRY TO EQUAL
.SEE EQUAL
GCD.C: .SEE GCDBB
ATAN.X: .SEE ATAN ;TEMPORARY X VALUE
GWDCNT: 0
GCD.D: .SEE GCDBB
ATAN.Y: .SEE ATAN ;TEMPORARY Y VALUE
GWDORG: 0 ;ORIGIN OF LAPPIFICATION - GWDRG1 IS GWDORG-1
GWDRG1: 0
EXPL5: 0 ;TEMP FOR EXPLODE
GCD.UH: .SEE GCDBB
BKTRP: .SEE BAKTRACE
EV0B: .SEE EVAL
FLAT1: .SEE FLATSIZE
MEMV: 0 .SEE MEMBER
UAPOS: ;-1 => UWRITE, >=0 => UAPPEND .ACCESS POS
GCD.VH: .SEE GCDBB
LPNF: ;-1 MEANS NOT A LONG PNAME (FITS IN PNBUF)
.SEE RINTERN
AUNBR: 0 ;SAVES R FOR AUNBIND
DLTC: 0 ;# OF TIMES DELETE/DELQ SHOULD REMOVE ITEM
.SEE DELQ
RINF:
APFNG1:
TABLU1: 0
AUNBF: ;SAVES F FOR AUNBIND
IFE BIGNUM,[
MNMX0: ;"MIN" INSTRUCTION
GRESS0: 0 ;"GREATERP" INSTRUCTION
] ;END OF IFE BIGNUM
IFN BIGNUM,[
GRESS0: 0 ;"MIN" AND"GREATERP" INSTRUCTION
CFAIL: JRST . ;TRANSFER ON FAILURE
CSUCE: JRST . ;TRANSFER ON SUCCEED
] ;END OF IFN BIGNUM
10% IOST: .STATUS 00,A
IFN ITS, SYSCL8:
BACTYF: 0 ;ZERO ON FIRST LOOP THROUGH BACTRACE.
BOOLI: SETZB D,TT ;BOOLEAN INSTRUCTION FOR BOOLE
IFN USELESS, PRINLV: ;<CURRENT PRINT LEVEL>-1
PLUS0: 0 ;TYPE - QFIXNUM OR QFLONUM
IFE BIGNUM,[
PLUS3: ADD D,TT
PLUS6: FAD D,TT ;FLOAT-POINT INSTRUCTION FOR ARITH GENERATOR
] ;END OF IFE BIGNUM
IFN USELESS, ABBRSW: ;KIND OF STUFF DESIRED FROM PRINT0:
; - => ONLY ABBREV STUFF
; 0 => ONLY NON-ABBREV STUFF
; + => BOTH (DISTINGUISHED BY TYOSW)
PLUS8: 0 ;<N,,N> WHERE THERE ARE N ARGS
RM4: 0
IFN USELESS, PRPRCT: ;PRINT'S PARENS COUNTS (LEFT,,RIGHT)
SWNACK: 0 ;USED FOR WNA CHECKING IN STATUS
JRST STAT1
IFN USELESS, TYOSW: 0 ;NORMALLY ZERO - TELLS TYO TYPE OF CHAR
; + => CHAR IS FOR FILES ONLY
; - => CHAR IS FOR TTY ONLY
; 0 => CHAR IS FOR BOTH FILES AND TTY
RDBKBF: 0 ;OCCASIONALLY, A BREAK CHARA HAS TO BE BUFFERED BACK
RDBKC: 0 ;SAVED BREAK CHARACTER, ON EXIT FROM RDCHAR
RDNSV: 0 ;SAVED NUMBER (BEFORE DECIMAL-OR-NOT IS DECIDED)
RDDSV: 0 ;SAVED VALUE OF # OF DIGITS TO RIGHT OF DECIMAL POINT
RDIBS: 0 ;NUMERIC IBASE DURING READING
IFN USELESS, RDROMP: 0 ;ROMANP - ARE ROMAN NUMERALS OK?
RDINCH: 0 ;SOURCE OF CHARACTERS FOR READ
CORBP: 0 ;BYTE-POINTER FOR READ-SOURCE WHEN SOURCE IS BLOCK OF
;ASCII OR SIXBIT STUFF IN CORE
MKNCH: 0 ;INSTRUCTIION FOR MAKNAM TO GET NEXT BYTE
PNBP: 440700,,PNBUF ;BYTE POINTER FOR PNAME BUFF
;;; BUFFER FOR MACDMP/VALRET STRINGS AND JCL. OVERLAPS BIGNUM STUFF.
MAYBE LPNBUF==10
MACOUT: 0
PNBUF: BLOCK LPNBUF
0
JCLBF==PNBUF+1 ;SINCE STATUS JCL MAY CALL INTERN ON A SCO
ATMBF==PNBUF+1 ;DITTO INTERACTION BETWEEN PRINTA AND EXPLODE
IFN BIGNUM,[
REMFL: 0 ;REMAINDER FLAG
VETBL0: 0 ;DIVISION STUFF
DVS1: 0
DVS2: 0
DVSL: 0
DD1: 0
DD2: 0
DD3: 0
DDL: 0
NORMF: 0
QHAT: 0
BNMSV: 0
FACF: 0
FACD: 0
AGDBT: 0
YAGDBT: 0
TSAVE: 0
DSAVE: 0
RSAVE: 0
FSAVE: 0
NRD10FL: 0 ;NOT READING IN BASE 10. FLAG
]
IFG JCLBF+24-., BLOCK JCLBF+24-. ;MUST HAVE AT LEAST 24 WDS
LVLRTS==.-MACOUT ;LENGTH OF VALRET STRING BUFFER
LJCLBF==.-JCLBF
IFE QIO,[
ERROR3: 0 ;PRINT OUT ERROR MESSAGE
JRST EROR3A
ERROR4: 0 ;PRINT OUT FOR OTHER KINDS OF ERRORS
JRST EROR4A
] ;END OF IFE QIO
UUOH: ;KEEP THIS UUO STUFF CONTIGIOUS SO THAT GC CAN SAVE IT.
ERROR: 0
JRST UUOH0
ERBDF: ;SOME RANDOM TEMP FOR UUO HANDLER
UUOFN: 0 ;POINTER TO FUNCTION DURING THE UUOH1 LOOP
UUTSV: 0
UUTTSV: 0
UURSV: 0
UUALT9: .SEE UUALT ;DOESN'T CONFLICT WITH UUPSV
UUPSV: 0
UUOBKG: 0 ;IF IN *RSET MODE, PUT STUFF ON PDL
LUUSV==.-UUOH ;STUFF THAT NEEDS SAVING FOR THE UUO HANDLER
LSWS==.-SWS
JRST UUBKG1
;;; ******** STUFF SAVED UPON USER INTERRUPT ENDS HERE ********
SUBTTL FREE STORAGE LISTS, AND GC AND ALLOC PARAMETERS
;;; ********** FREE STORAGE LISTS **********
;;; THESE ARE USED BY THE VARIOUS CONSERS TO ALLOCATE CELLS OF
;;; THE VARIOUS FREE STORAGE SPACES. NEVER PUT ONE OF THESE IN
;;; A MARKABLE AC (EXCEPT WITHIN A PROPERLY PROTECTED CONSER)!
;;; CAUTION! MUST PRESERVE RELATIVE ORDERING OF
;;; FFS,FFX,FFL,FFB,FFY,FFH,FFA,FFY2
;;; SEE GARBAGE COLLECTOR (GC)
FFS: 0 ;LIST FREE STORAGE LIST
FFX: 0 ;FIXNUMS (AND PNAME WORDS)
FFL: 0 ;FLONUM WORDS LIST
IFN BIGNUM, FFB: 0 ;BIGNUM HEADERS
FFY: 0 ;SYMBOL (PNAME-TYPE ATOM) HEADERS
IFN HNKLOG, FFH: REPEAT HNKLOG, SETZ ;HUNKS
FFA: 0 ;SARS (ARRAY POINTERS)
NFF==:.-FFS ;NUMBER OF FF FROBS
FFY2: SY2ALC ;SYMBOL BLOCKS (EXPLICIT RETURN USED)
;;; SIGN BIT IN FF- MEANS EXEMPT FROM 40-WORD MINIMUM RECLAIMED.
.SEE GCSWH1
.SEE AGC1Q
.SEE GCE0C5
.SEE GCE0C9
.SEE HUNK
;;; MUST PRESERVE RELATIVE ORDERING OF NPFFS THROUGH EPFFB
NPFFS: 0 ;PURE FREE STORAGE COUNTERS
NPFFX: 0
NPFFL: 0
IFN BIGNUM, NPFFB: 0
NPFFY2: 0
EPFFS: 0
EPFFX: 0
EPFFL: 0
IFN BIGNUM, EPFFB: 0
EPFFY2: 0
PSGAOB: 0 ;AOBJN PTR FOR ALLOCATING PURE SEGMENTS
EFVCS: BVCSG+NVCSG*SEGSIZ ;END OF CURRENT VC REGION (EFVCS+NFVCS=LAST USED VC)
NFVCP: NXVCSG/SGS%PG ;NUMBER OF EXTRA VC PAGES
FFVC: BFVCS ;VALUE CELL FREELIST (EXPLICIT RETURN USED)
;;; GCMKL IS ARRANGED LIKE A PROPERTY LIST: THE "PROPERTY NAMES"
;;; ARE SARS, IN DECREASING ORDER OF POSITION IN ARRAY SPACE,
;;; AND THE "PROPERTY VALUES" ARE FIXNUMS DENOTING THE LENGTHS
;;; OF THE ARRAYS. USED BY GC, RETSP, GRELAR, *ARRAY, AND OTHERS
;;; TO KEEP TRACK OF ARRAYS. NOTE: THE INITIAL OBARRAY AND
;;; READTABLE ARE NOT IN GCMKL SINCE THEY ARE NOT IN BPS.
GCMKL: IGCMKL
;;; PROLIS IS AN ALIST USED TO PROTECT NON-ATOMIC READ-MACRO
;;; FUNCTIONS FROM BEING GC'ED. EACH ITEM ON THE
;;; ALIST IS OF THE FORM (FUN RDT . NUM) WHERE:
;;; FUN IS THE FUNCTION TO BE PROTECTED
;;; RDT IS THE SAR OF THE READTABLE CONCERNED
;;; NUM IS A LISP NUMBER (GUARANTEED NLISP INUM)
;;; <ASCII CHAR VALUE> FOR READ-MACRO FUNCTION
;;; PROLIS IS UPDATED BY SSGCPRO AND SSGCREL.
PROLIS: NIL
;;; VARIOUS RANDOM PARAMETERS FOR GARBAGE COLLECTOR
MFFS: MINFFS ;CAUTION!! MUST PRESERVE RELATIVE
MFFX: MINFFX ; ORDERING UP TO (BUT NOT INCLUDING)
MFFL: MINFFL ; PANICP (SEE GC AND OTHERS)
IFN BIGNUM, MFFB: MINFFB
MFFY: MINFFY
IFN HNKLOG, MFFH: REPEAT HNKLOG, MINFFH
MFFA: MINFFA
IFN .-MFFS-NFF, WARN [MFF- TABLE WRONG LENGTH]
NFFS: 0
NFFX: 0
NFFL: 0
IFN BIGNUM, NFFB: 0
NFFY: 0
IFN HNKLOG, NFFH: REPEAT HNKLOG, 0
NFFA: 0
IFN .-NFFS-NFF, WARN [NFF- TABLE WRONG LENGTH]
PANICP: 0 ;-1 SAYS WE'RE CLOSE TO RUNNING OUT OF CELLS
GCMRKV: 0 ;NON-NIL MEANS MARK PHASE ONLY
GCTIM: 0 ;GC TIME
GCTM1: 0
IFN USELESS*QIO*ITS,[
GCWHO1: 0
GCWHO2: 0
GCWHO3: 0
GCWHO: 0
] ;IFN USELESS*QIO*ITS
GCACSAV: BLOCK NACS+1 ;MARKED ACS SAVED HERE
GCNASV: BLOCK 20-<NACS+1> ;UNMARKED ACS SAVED HERE
Q$ GCP=GCACSAV+P
Q$ GCFLP=GCACSAV+FLP
Q$ GCFXP=GCACSAV+FXP ;TEST GCFXP FOR NON-ZERO TO DECIDE IF
Q$ GCSP=GCACSAV+SP ; INSIDE GC AND PDL POINTERS ARE HERE
GCUUSV: BLOCK LUUSV
IRMVF: 0 ;GCTWA REMOVAL OVERRIDE SWITCH
GCRMV: 0 ;WHETHER TO DO GCTWA REMOVAL
ARPGCT: 4 ;# OF PAGES TO GRAB FREELY FOR ARRAYS BEFORE GC
;;; PARAMETERS RELEVANT TO MEMORY ALLOCATION.
;;; MUST PRESERVE RELATIVE ORDERING OF MOST OF THIS STUFF.
;USED BY GC TO HOLD EXACT CALCULATED GCMINS
ZFFS: 0
ZFFX: 0
ZFFL: 0
IFN BIGNUM, ZFFB: 0
ZFFY: 0
IFN HNKLOG, ZFFH: REPEAT HNKLOG, 0
ZFFA: 0
IFN .-ZFFS-NFF, WARN [ZFF- TABLE WRONG LENGTH]
;SIZE OF EACH SWEEPABLE SPACE.
;USED TO CALCULATE PERCENTAGE RECLAIMED.
SFSSIZ: NIFSSG*SEGSIZ
SFXSIZ: NIFXSG*SEGSIZ
SFLSIZ: NIFLSG*SEGSIZ
IFN BIGNUM, SBNSIZ: NBNSG*SEGSIZ
SSYSIZ: NSYMSG*SEGSIZ
IFN HNKLOG, SHNSIZ: REPEAT HNKLOG, 0
SSASIZ: NSARSG*SEGSIZ
IFN .-SFSSIZ-NFF, WARN [S--SIZ TABLE WRONG LENGTH]
;SIZE FOR EACH SPACE BELOW WHICH TO GRAB NEW SEGMENTS FASTLY
; (I.E. WITHOUT DOING A WHOLE GARBAGE COLLECTION FIRST)
GFSSIZ: MAXFFS
GFXSIZ: MAXFFX
GFLSIZ: MAXFFL
BG$ GBNSIZ: MAXFFB
GSYSIZ: MAXFFY
IFN HNKLOG, GHNSIZ: REPEAT HNKLOG, MAXFFH
GSASIZ: MAXFFA
IFN .-GFSSIZ-NFF, WARN [G--SIZ TABLE WRONG LENGTH]
;;; ROOTS OF THE CHAINS LINKING LIKE PAGES IN THE GARBAGE COLLECTOR
;;; SEGMENT TABLE (GCST). FILLED IN AT INIT TIME
FSSGLK: 0
FXSGLK: 0
FLSGLK: 0
BG$ BNSGLK: 0
SYSGLK: 0
IFN HNKLOG, HNSGLK: REPEAT HNKLOG, 0
SASGLK: 0
IFN .-FSSGLK-NFF, WARN [--SGLK TABLE WRONG LENGTH]
S2SGLK: 0 ;THIS MUST FOLLOW THOSE ABOVE!
BTSGLK: 0 ;LINKED LIST OF BIT BLOCKS
IMSGLK: 0 ;LINKED LIST OF IMPURE SEGMENTS (INIT SETS UP)
BTBAOB:
10% -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,,BFBTBS←<5-SEGLOG>
10$ -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,, .SEE IN10S5
MAINBITBLT: BFBTBS-1 ;END ADDRESS FOR BLT OF MAIN BIT BLOCK AREA
GC98: 0 ;RANDOM TEMP FOR GC
GC99: 0 ;RANDOMER TEMP FOR GC
PFSSIZ: NPFSSG*SEGSIZ ;SIZE OF PURE FREE STORAGE AREAS
PFXSIZ: NPFXSG*SEGSIZ ; - USED MAINLY BY STATUS
PFLSIZ: NPFLSG*SEGSIZ
BG$ PBNSIZ: 0 ;AIN'T NO INITIAL PURE BIGNUMS, BABY!
PS2SIZ: NSY2SG*SEGSIZ
;;; ********** HAIRY PARAMETERS HACKED BY ALLOC **********
BPSH: ;BINARY PROG SPACE HIGH
IFE ITS, 0
.ELSE <<ENDLISP+PAGSIZE-1>&PAGMSK>-1
BPSL: BBPSSG ;BINARY PROG SPACE LOS
10% HINXM: 0 ;ADDRESS OF LAST WORD OF NXM HOLE
10$ HIXM: 0 ;ADDRESS OF LAST WORD OF LOW SEGMENT
10$ MAXNXM: 0 ;HIGHEST USABLE WORD OF NXM ABOVE LOW SEGMENT
NPDLL: 0 ;FOR SPECBIND AND PDLNMK (Q.V.)
NPDLH: 0
IFN ITS,[
PDLFL1: 0 ;FOR FLUSHING PDL PAGES - SEE ERINIT
PDLFL2: 0 ;FOR UPDATING ST - SEE ERINIT
] ;END OF IFN ITS
;;; THE NEXT FEW THINGS MUST BE IN THIS ORDER
XFFS: 0 ;MAXIMUM SIZES FOR STORAGE SPACES
XFFX: 0
XFFL: 0
IFN BIGNUM, XFFB: 0
XFFY: 0
IFN HNKLOG, XFFH: REPEAT HNKLOG, MAXFFH
XFFA: 0
IFN .-XFFS-NFF, WARN [XFF- TABLE WRONG LENGTH]
IFN ITS,[
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
XPDL: MAXPDL ;MASTER PDL POSITIONS TO GIVE
XFLP: MAXFLP ; PDL-LOSSAGE INTERRUPTS AT
XFXP: MAXFXP
XSPDL: MAXSPDL
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
ZPDL: MAXPDL ;ACTUAL PDL POSITIONS FOR LOSING
ZFLP: MAXFLP ;INITIALIZED AT ERINIT FROM XPDL ET AL.
ZFXP: MAXFXP ; AND DIDDLED BY PDLOV AT OVERFLOW TIME
ZSPDL: MAXSPDL
] ;END OF IFN ITS
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
C2: -PAGSIZ+NACS+1+2,,PDLORG-1 ;STANDARD REG PDL PTR
FLC2: -PAGSIZ+2,,FLPORG-1 ;STANDARD FLO PDL PTR
FXC2: -PAGSIZ+2,,FXPORG-1 ;STANDARD FIX PDL PTR
SC2: -PAGSIZ+1+2,,SPDLORG ;STANDARD SPEC PDL PTR
ZSC2: SPDLORG ;SC2 WITH ZERO LEFT HALF
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
OC2: 0 ;ABS LIMITS FOR PDLS
OFLC2: 0
OFXC2: 0
OSC2: 0
SUBTTL RANDOM VARIABLES IN LOW CORE
;;; I GUESS THIS STUFF NEED NOT BE CONSIDERED SACRED
Q% MAYBE LINTAR==6
Q$ MAYBE LINTAR==20+10*JOBQIO+5*USELESS ;ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTERRUPTS
INTAR: 0 ;INDEX INTO INTERRUPT ARRAY (FIFO QUEUE)
BLOCK LINTAR ;ENTRIES OF FORM <INT #,,ARG FOR INT FN>
;RIGHT HALVES ARE PROTECTED BY GC
Q% MAYBE LUNREAR==6
Q$ MAYBE LUNREAR==20+10*JOBQIO+5*USELESS ;ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTERRUPTS
UNRC.G: 0 ;-2/-3 FOR DELAYED ↑X/↑G INTERRUPT
Q$ IFN USELESS, UNRCLI: 0 ;ENTRY FOR DELAYED CLI INTERRUPT
Q$ IFN USELESS, UNRMAR: 0 ;ENTRY FOR DELAYED MAR INTERRUPT
UNRRUN: 0 ;ENTRY FOR DELAYED RUNTIME ALARMCLOCK
UNRTIM: 0 ;ENTRY FOR DELAYED REAL TIME ALARMCLOCK
UNREAR: 0 ;INDEX INTO "REAL TIME" INTERRUPT QUEUE
BLOCK LUNREAR ;ENTRIES OF FORM <ARG FOR INT FN,,INT #>
;ARGS IN UNREAR NEED NO GC PROTECTION
.SEE NOINTERRUPT
;;; LH OF MUNGP => GC IS IN PROCESS OF USING MARK BITS
;;; IN SARS OR SYMBOLS
;;; RH OF MUNGP => ALIST IS IN PROCESS OF USING LH'S OF
;;; VALUE CELLS FOR SPECPDL HACKERY
;;; ERINIT CHECKS MUNGP AND ATTEMPTS TO RESTORE THINGS IF
;;; NECESSARY. THIS SHOULD HAPPEN ONLY IN THE CASE OF SOME
;;; GROSS BUG LIKE A MEMORY VIOLATION.
MUNGP: 0
BFTMPS==. ;FASLOAD TEMPORARIES
SQ6BIT: 0 ;TEMPORARIES FOR SQUEEZE
SQSQOZ: 0
LDBYTS: 0 ;WORD OF RELOCATION BYTES
LDOFST: 0(TT) ;LOAD OFFSET (RELOCATION FACTOR = VALUE OF BPORG BEFORE LOAD)
LDEOFJ: 0 ;JUMP ADDRESS FOR END OF FASLOAD INPUT FILE
LDAAOB: 0 ;AOBJN INDEX FOR ATOMTABLE ARRAY
LDTEMP: ;RANDOM TEMPORARY
LD6BIT: 0 ;PLACE TO ACCUMULATE SIXBIT WHILE CONVERTING FROM SQUOZE
; - FIRST 6 BITS OF NEXT WORD MUST BE ZERO
LDAPTR: 0(TT) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE ATOMTABLE
LDBPTR: 0(F) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE I/O BUFFER
LDF2DP: 0 ;.FNAM2-DIFFERENT-P (NON-ZERO MEANS FASLAP'S LDFNM2 WAS DIFFERENT FROM CURRENT FASLOAD'S)
LDASAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S ATOMTABLE ARRAY
LDBSAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S I/O BUFFER ARRAY
LDXBLT: 0 ;BLT POINTER FOR ZAPPING CALLS FOR XCTS IN BPS
LDXSIZ: 0 ;0=XCT HACKERY NEVER DONE, -1=DONE AND PURIFIED, N>0=LENGTH (IN WORDS) OF AREA FOR XCTED CALLS
LDXSM1: 0 ;CONTAINS 1 LESS THAN LDXSIZ, AND RETAINS VALUE AFTER LDXSIZ BECOMES -1
LDHLOC: 0 ;HIGHEST LOC ASSEMBLED INTO + 1
LFTMPS==.-BFTMPS ;NUMBER OF FASLOAD TEMPORARIES
10% IUSN: 0 ;INITIAL USER SNAME - SET BY LISPGO
IFE QIO,[
USN: BLOCK 2 ;USER SYSTEM NAME
10% UTOBYT: -1 ;# OF VACANT BYTES LEFT IN UTAPE OUTPUT BUFFER
UTOOPD: 0 ;UTAPE OUTPUT OPENED FLAG (NON-ZERO MEANS TRUE)
UTIOPD: 0 ;UTAPE INPUT OPENED FLAG
UTIN: (SIXBIT \DSK\) ;FOR ITS, HAS MODE BITS IN LH, 3 SIXBIT CHARS FOR DEVICE IN RH
BLOCK 4 ;FOR ITS, USED AS DATA BLOCK ON OPENS
UWRT: 0
] ;END OF IFE QIO
IFN D10,[
IFE QIO,[
UWUSN: 0 ;UWRITE SNAME (I.E. PPN)
D10PTR: 0 ;AOBJN POINTER FOR DEC BUFFERS..
D10ARD: -UTBSIZ,,. ;I/O WORD FOR ARRAY DUMP AND FASL
0
D10NAM: 0 ;THIS WORD ;WILL BE ###LSP WHERE ###=JOB NR
D10REN: BLOCK 2 ;FILE NAME TO
] ;END OF IFE QIO
SYMLO: 0 ;LOW BOUNDARY FOR DDT'S SYMBOL TABLE
UPCOK: -1 ;-1 => TYPING ↑C IS OK. NON-NEG INHIBITS,
; AND CAUSES DELAY OF ↑C INTERRUPTS.
; POS => THERE IS A ↑C REQUEST STACKED UP.
] ;END OF IFN D10
IFE QIO,[
UUN: BLOCK 2 ;UNAME
UFN1: BLOCK 2 ;FN1, LFT BY MOST RECENT UREAD, FASLOAD
UFN2: BLOCK 2
URFN1: BLOCK 2
URFN2: BLOCK 2 ;FN2
SPP: 0 ;PAGE-PAUSE-P PAUSE AT END OF DATAPOINT PAGE IF NON-NIL
SRNLN1: 0 ;SCREEN LENGTH FOR DISPLAY TERMINAL, 0 FOR PRINTING
PAUSFL: 0 ;FLAG TO HANG ON PAUSE FEATURE, -1 TO CONTINUE, +N TO CLEAR SCREEN
STTYSS: 0 ;TTY STATUS WORD
STTYS1: 0 ;TTY INTERRUPT AND WAKEUP CONTROL, FIRST WORD
STTYS2: 0 ; SECOND WORD; MUST FOLLOW FIRST!
TTYDISP: -1 ;TERMINAL TYPE (0 => PRINTING)
LINMODE: SA% NIL ;NON-NIL => LINE BUFFERING MODE (STATUS LINMODE)
SA$ TRUTH
] ;END OF IFE QIO
RDOBJ8: RD8N ;OR RD8W FOR WHITE'S + HAC
ALGCF: 0 ;FLAG TO STOP THE GC WHILE IN ALLOC
AFILRD: -1 ;-1 => NO INIT FILE, >0 => CDR OF ALLOC COMMENT
GNUM: ASCII \G0000\ ;INITIAL GENSYM
;;; RANDOM STUFF FOR RANDOM NUMBER GENERATOR
RNOWS: 36.
RBACK: 71.
RBLOCK: -267233364510 ? 150024234754 ? 3742123646
35711501456 ? 352107676232 ? 50527256770
167457050150 ? -43117344752 ? 334060175522
262357222474 ? 216372106452 ? -243216775730
330162137650 ? -217034631306 ? -112616124724
-320153511274 ? 136777110030 ? -132175077316
142234503276 ? 6001657246 ? -266602313352
-344303247744 ? 43640264406 ? -323622142366
272155266302 ? -342425450266 ? 227626464066
364546575562 ? -356307627720 ? -11354210732
200740776250 ? -10165011334 ? -162161647420
-120575351206 ? 127617717662 ? -164125613224
-17405051702 ? 253370067252 ? -256526020572
-55463531726 ? -246715511012 ? 240267244772
-201055605142 ? 63550073664 ? -333012475562
150133145156 ? -113277052560 ? -25217065400
75437127132 ? -206200652214 ? -320251161276
347117363560 ? -107725100124 ? 35540004440
145373707566 ? 352324550530 ? -173602227164
-254604350106 ? -336734270452 ? 256415642606
164655127254 ? 77346163112 ? 210134701414
136703675276 ? 73775356620 ? 134422373564
-150505346144 ? 265472454540 ? 371055406470
242624146270 ? -322753006552
IFN SAIL,[
ACLKTYP: 0 ;Q$RUNTIME OR QTIME
ATTSV: 0 ;SAVE TT DURING ALAMR
SAINTER: 200,,0 ;NEW STYLE CLOCK INTERRUPT MASK
SAICONT:0 ;CONTINUE POINT FOR INTUUO
SAIALK: 0
SAILJOB: 0
AIPCLOK: 0
0
] ;END OF IFN SAIL
IFN EDFLAG,[
EDPRFL: 0
EDPRN: EDPRW
EDEX2: 0
] ;END OF IFN EDFLAG
IFN MOBIOF,[
NVSCL: 20,, ;SCALING FOR NVFIX - NORMALLY CONVERTS 0 - 37777 TO 0 1777
FTVO: SIXBIT \ &DSK\ ;FAKE TV STUFF
BLOCK 2
CURBLK: 0 ;NUMBER OF BLOCK STORED IN ARRAY POINTED TO BY BUFFER
BUFFER: 0 ;POINTER TO SAR OF BUFFER ARRAY
NFTVBL: 0 ;CURRENT NUMBER OF BLOCKS IN CORE
MFTVBL: 4 ;MAX ALLOWABLE, BEFORE DELETIONS OF BLOCKS IN CORE OCCURS
XBLOKS: 0
YBLOKS: 0
NBLOKS: 0 ;TOTAL NUMBER OF BLOCKS
XLL: 0 ;X LOWER-LEFT
YLL: 0 ;Y "
XUR: 0 ;X UPPER-RIGHT
YUR: 0 ;Y "
NVDCL: 0 ;DIM CUTOFF LEVL
NVCFL: 0 ;CONFIDENCE LEVEL OF IMAGE
NVDK: 0 ;DIM CUTOFF ON FAKETV
ODCL: 0 ;LAST DIM CUTOFF ON FAKETV
PLTTBP: 0 ;BYTE POINTER FOR PLOTTEXT
PLTTBF: 0 ;BUFFER FOR PLOTTEXT
PLTLST: 0 ;CELL FROM WHICH TO DO A PSTRTL
] ;END OF IFN MOBIOF
IFE QIO,[
IFN ITS, URCHST: BLOCK 6 ;FOR UREAD'S .RCHST (READ CHANNEL STATUS)
POV2: . ;ADDRESSES OF ERROR MESAGE FOR PDLOV
LTYOC: 0 ;NON-ZERO => LAST CHAR OUTPUT BY TYO WAS A SLASH
PBFTY: 0 ;CHARACTER BUFFERED UP IN TTY CHANNEL
IFN ITS, IODF1: SIXBIT \↑M !\ ;TO BE USED WHEN A DEVICE FULL MESSAGE NEEDED
] ;END OF IFE QIO
RNTN2: .(T) ;CURRENT PNBUF WORD FOR COMPARE ON INTERN
;;; VARIABLES FOR ARRAY ALLOCATOR
BPPNR: 0 ;<SIZE OF ARRAY HEADER>,,-<SIZE OF ARRAY DATA>
GAMNT: 0 ;NUMBER OF WORDS REQUIRED, ON A CALL TO GETSP
GSBPN: 0 ;USED AS TEMPORARY BPEND WHILE BLT'ING DOWN ARRAYS
ADDSAR: 0 ;ADDRESS OF SPECIAL ARRAY CELL WHEN MAKIN ARRAY
TOTSPC: 0 ;<# OF ARRAY DIMS>,,<TOTAL SPACE NEEDED FOR ARRAY>
LLIP1: 0 ;<LARGEST LEGAL INDEX OF ARRAY>+1
INSP: 0 ;PSEUDO-PDL POINTER FOR ARRAY-ING
RTSP1: 0
RTSP3: 0
LOSEF: 77 ;LAP OBJECT STORAGE - EFFICIENCY FACTOR. FOR (STATUS LOSEF) = N,
;THERE WILL BE <1←N>-1 STORED HERE. SIZE OF GC PROTECTION ARRAY
RWG: 0 ;IF = 0, THEN CREATE ERROR ON DIVIDE BY ZERO,
;OR FLOATING OVFLO ON CONVERSION OF BIGNUM
FLOV9A: 0 ;RANDOM TEMPS FOR FLOATING POINT
FLOV9B: 0 ; OVERFLOW INTERRUPT HANDLER
CPJSW: 0 ;IF NOT ZERO, THEN *RSET WAS ON, AND BAKTRACE WILL FIND MUCH
;INFORMATION FROM THE [FUN,,CPOPJ] TYPE STUFF ON THE PDL
PSYMF: 0 ;NON-ZERO DURING EXECUTION OF PSYM.
POFF: 0 ;VARIOUS ROUTINES INVOLVING $X'S FROM DDT DO JSR'S HERE
JRST PSYM1
PSMS: BLOCK 20 ;THIS SHOULD BE ENOUGH FOR LPSMTB
BLOCK 3
PSMTS: 0
PSMRS: 0
10% SQUOZE 0,. ;FOR A .BREAK 12,[4,,PS.S-1]
PS.S: 0 .SEE PSYM1
IFN <1-QIO>*ITS,[
RD0S3: ASCII \⊂Hλ⊂V\ ;REPOSITION DISPLAY CURSOR
0 ; (↑P H ↑H ↑P V)
] ;END OF IFE QIO
STQLUZ: 0 ;FOR LOSSAGE OF SETQING NIL OR T - REMEMBER WHICH ONE OVER INTWAIT
OLINEL: 0 ;INITIAL SETTING OF LINEL BY TTYOPN (THIS IS AN
; NLISP INUM; HENCE NEEDS NO GC PROTECTION)
NOPFLS: 0 ;NON-ZERO => PURIFY$G SHOULDN'T FLUSH PDLS
10% SAWSP: -1 ;SCREW-AROUND-WITH-SHARING-P
SUBTTL KILHGH AND GETHGH
IFN D10,[
KILHGH: MOVEI A,GETHGH ;KILL HIGH SEGMENT
HRRM A,.JBSA" ;SET START ADDRESS
SA$ SETDDT=047000,,2
SA$ MOVEI A,. ;FOO, HOW MANY WAYS CAN SAIL LOSE?
SA$ SKIPN .JBDDT
SA$ SETDDT A, ;JOBDDT MUST BE NON-ZERO TO SAVE!
MOVSI A,1
SKIPE SGANAM
SKIPN SGADEV
JRST .+3
CORE A, ;FLUSH HIGH SEGMENT
JFCL
EXIT 1, ;CONTINUE
GETHGH: MOVEI A,A+1 ;SET UP TO GET HIGH SEG BACK
MOVE A+1,SGADEV
MOVE A+2,SGANAM
SETZB A+3,A+4
MOVE A+5,SGAPPN
SKIPE SGANAM
SKIPN SGADEV
JRST .+3
GETSEG A, ;GET HIGH SEGMENT
JRST GLSLUZ
JSP F,JCLSET
RETHGH: JRST . ;RETURN ADDR CLOBBERED IN HERE
GLSLUZ: OUTSTR [ASCIZ \?LISP.SHR WENT AWAY
\]
EXIT ;FOO
SGANAM: 0
SGADEV: 0
SGAPPN: 0
SA$ SAILFL: 0
SA$ SAILF2: 0
MAYBE LSJCLBUF==10 ;ENOUGH FOR 40. CHARS
SJCLBUF: 0 ;FIRST WORD HOLD NUMBER OF CHARS BUFFERED
BLOCK LSJCLBUF
0 ;INSURES THAT ILDBS WILL FINALLY SEE A ZERO
] ;END OF IFN D10
SUBTTL INITIAL READTABLE, OBARRAY (IN LOW CORE), AND PURTBL
;;; INITIAL READ SYNTAX TABLE IN FORM OF AN ARRAY
-1,,0 ;IN NEWIO, WILL POINT TO MACRO CHAR LIST
RSXTB1: PUSH P,CFIX1
JSP TT,1DIMF
READTABLE
0
RCT: BLOCK LRCT-2 ;WHICH IS BLT'D IN FROM RCT0
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; INITIAL OBLIST IN FORM OF ARRAY
-<OBTSIZ+1>/2,,IOBAR2
IOBAR1: JSP TT,1DIMS
OBARRAY
OBTSIZ+1+200
IOBAR2: BLOCK <OBTSIZ+1>/2
BLOCK 200/2 ;SINGLE CHAR OBJS TABLE (CREATED AS NEEDED)
;;; PURE PAGE TABLE
;;; CONTAINS TWO BITS FOR EACH PAGE, 16 PAGES PER TABLE WORD
;;; MEANING OF BITS: 00=NXM 01=IMPURE
;;; 10=PURE 11=SPECIAL HACKERY NEEDED
IFN ITS,[
PURTBL:
IF1, BLOCK NPAGS/20
IF2,[
ZZW==. ;DARN WELL BETTER BE SAFE OVER THE FOLLOWING MESS!
.BYTE 2
ZZZ==0
$==3 ;FOR HAIRY PRINTOUT TO WORK
PRINTX \
INITIAL PURTBL MEMORY LAYOUT
[0=NXM, 1=IMPURE, 2=PURE, $=BPS/PDL/SCRATCH]
\
NLBTSG==0
NHBTSG==0
IFN LOBITSG, NLBTSG==NBITSG
.ELSE, NHBTSG==NBITSG
;;; IN THE IRP BELOW, COMMAS AND CR'S MARK GUARANTEED PAGE BOUNDARIES
IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
BITS
ZZZ==ZZZ+1
IFE ZZZ&17,[
0
0
]
PRINTX \BITS\
IFE <ZZZ#10>&17, PRINTX \ \
IFE <ZZZ#20>&37, PRINTX \ \
IFE ZZZ&37,[
PRINTX \
\
]
] ;END OF REPEAT
TERMIN
.BYTE
IFN ZZZ-NPAGS,[
WARN \ZZZ,[=WRONG LENGTH FOR PURTBL (SHOULD BE ]\NPAGS,[)]
LOC ZZW
] ;END OF IFN ZZZ-NPAGS
PRINTX \
\
] ;END OF IF2
] ;END OF IFN ITS
SUBTTL OLD I/O BUFFERS, PATCH AREAS
IFE QIO,[
DEFINE OPNWRD A,B,E
O!A!C: IFSE E,, (B+SIXBIT \A\)
IFSN E,, (B+SIXBIT \E\)
A!OPD: 0
TERMIN
OPNWRD LPT,1
IFN MOBIOF,[
OPNWRD IPL,5
OPNWRD NVD,0
OPNWRD BVD,2,NVD
OPNWRD IMX,0
OPNWRD OMX,1
OPNWRD DIS,1
SIXOPD: 0 ;-1 FOR 6, +1 FOR 10 SLAVE
] ;END OF IFN MOBIOF
] ;END OF IFE QIO
CONSTANTS
;;; NO MORE CONSTANTS PERMITTED AFTER THIS IN THE LOSEG (WRITEABLE FIRST PAGE)
IFE QIO,[
IFE D10,[
UTBSIZ==20
ZZ==.
SEGUP .
IFL .-ZZ-2*UTBSIZ-5,[
SEGUP .+1
UTBSIZ==<.-ZZ-6>/2
] ;END OF IFL
LOC ZZ
UTIBP: 440700,,UTIB+UTBSIZ
UTIB: BLOCK UTBSIZ+1
UTOBP: 440700,,UTOB
UTOB: BLOCK UTBSIZ+1
SEGUP .
] ;END OF IFE D10
IFN D10,[
UTBSIZ==200
UTIHED: 0 ;BUFFER HEADER FOR DEC-10 UREAD INPUT
UTIBP: 0
UTIBYT: 0
UTOHED: 0 ;BUFFER HEADER FOR DEC-10 UREAD OUTPUT
UTOBP: 0
UTOBYT: 0
FSLHED: BLOCK 3 ;FOR FASLOAD BUFFER, ETC.
BLOCK 3 ;ROOM FOR FOOLISH HEADER
UTIB: BLOCK UTBSIZ+1
BLOCK 3 ;ROOM FOR FOOLISH HEADER
UTOB: BLOCK UTBSIZ+1
PATCH: BLOCK PTCSIZ
SEGUP .
EPATCH==.-1
LOPATCH==1
] ;END OF IFN D10
] ;END OF IFE QIO
10% LOPATCH==0
10% Q% INFORM [UTAPE BUFFER AREAS=],\UTBSIZ,[ WORDS APIECE]
IF1,[
ZZ==.
LOBITSG==0 ;NON-ZERO ==> BITSGS ARE LOW
PAGEUP
TOP.PG==.
IFGE TOP.PG-ZZ-SEGSIZ,[ ;SEE IF THERE IS ANOTHER SEGMENT LEFT ON THIS PAGE
SEGUP ZZ
SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
SPCBOT BIT
BTBLKS: BLOCK BTSGGS*SEGSIZ-1
SEGUP .
SPCTOP BIT,ST,[BIT BLOCK]
IFE TOP.PG-., LOBITSG==1
.ELSE,[
WARN [LOBITSG STUFF DIDN'T WORK]
EXPUNGE NZERSG NBITSG BBITSG
] ;END OF .ELSE
] ;END OF IFGE TOP.PG-ZZ-SEGSIZ
] ;END OF IF1
IF2,[
10% PAGEUP
10$ SEGUP .
] ;END OF IF2
IFE LOBITSG, SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
10$ EXPUNGE BZERSG
EXPUNGE TOP.PG
SUBTTL SEGMENT TABLES
;;; FORMAT OF SEGMENT TABLE (<NSEGS> WORDS, ONE FOR EACH SEGMENT)
;;; 4.9 LS 1=LIST STRUCTURE, 0=ATOMIC
;;; 4.8 $FS FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.7 $FX FIXNUM STORAGE (BUT NOT FIXNUM PDL)
;;; 4.6 $FL FLONUM STORAGE (BUT NOT FLONUM PDL)
;;; 4.5 BN BIGNUM HEADER STORAGE
;;; 4.4 SY SYMBOL HEADER STORAGE
;;; 4.3 SA SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO)
;;; 4.2 VC VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.1 $FXP FIXNUM PDL AREA
;;; 3.9 $FLP FLONUM PDL AREA
;;; 3.8 $XM EXISTENT (RANDOM) AREA
;;; 3.7 $NXM NONEXISTENT (RANDOM) AREA
;;; 3.6 PUR PURE SPACE (ONE OF BITS 4.8-4.5 OR 3.8 SHOULD BE ON)
;;; 3.5 HNK HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO)
;;; 3.4-3.1 UNUSED
;;; 2.9-1.1 ADDRESS OF A DATA TYPE, ATOM:
;;; QLIST, QFIXNUM, QFLONUM, QBIGNUM,
;;; QSYMBOL, QRANDOM, QARRAY, QHUNK<N>
;;; NOTE THAT THESE ATOMS OCCUPY CONSECUTIVE MEMORY
;;; LOCATIONS AND THUS NUMERICALLY ENCODE THE PAGE TYPE.
;;; THIS COMMENT SHOULD BE KEPT CONSISTENT WITH THE IRP
;;; DEFINING THE ABOVE SYMBOLS, AND WITH LOCATION PSYMTT.
SPCBOT ST
ST: ;SEGMENT TABLE
IFE ITS, BLOCK NSEGS ;FOR DEC-10, CODE IN INIT SETS UP THESE TABLES AT RUN TIME.
IFN ITS,[
IF1, BLOCK NSEGS
IF2,[
STDISP: EXPUNGE STDISP ;FOR .SEE
$ST ZER,$XM ;"ZERO" (LOW IMPURE) SEGMENTS
IFN LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST ST,$XM ;SEGMENT TABLES
$ST SYS,$XM+PUR ;SYSTEM CODE
$ST SAR,SA ;SARS (ARRAY POINTERS)
$ST VC,LS+VC ;VALUE CELLS
$ST XVC,$NXM ;RESERVED FOR EXTRA VALUE CELLS
$ST IS2,$XM ;IMPURE SYMBOL BLOCKS
$ST SYM,SY ;SYMBOL HEADERS
$ST XXA,$XM ;SLACK SEGMENTS (IMPURE!)
$ST XXZ,$NXM ;SLACK SEGMENTS (INITIALLY NXM)
$ST SY2,$XM+PUR ;PURE SYMBOL BLOCKS
$ST PFX,$FX+PUR ;PURE FIXNUMS
$ST PFS,LS+$FS+PUR ;PURE FREE STORAGE (LIST)
$ST PFL,$FL+PUR ;PURE FLONUMS
$ST XXP,$XM+PUR ;SLACK PURE SEGMENT (FOOEY!)
$ST IFS,LS+$FS ;IMPURE FREE STORAGE (LIST)
$ST IFX,$FX ;IMPURE FIXNUMS
$ST IFL,$FL ;IMPURE FLONUMS
IFN BIGNUM, $ST BN,BN ;BIGNUMS
$ST XXB,$XM ;SLACK SEGMENTS (IMPURE!)
IFE LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST BPS,$XM ;BINARY PROGRAM SPACE
$ST NXM,$NXM ;(INITIALLY) NON-EXISTENT MEMORY
$ST FXP,$FXP ;FIXNUM PDL
$ST XFXP,$NXM ;FOR FXP EXPANSION
$ST FLP,$FLP ;FLONUM PDL
$ST XFLP,$NXM ;FOR FLP EXPANSION
$ST P,$XM ;REGULAR PDL
$ST XP,$NXM ;FOR P EXPANSION
$ST SP,$XM ;SPECIAL PDL
$ST XSP,$NXM ;FOR SP EXPANSION
$ST SCR,$NXM ;SCRATCH SEGMENTS
.HKILL ST.ZER
IFN ST+NSEGS-., WARN \.-ST,[=WRONG SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END OF IF2
] ;END OF ITS
;;; THE FORMAT OF THE GARBAGE COLLECTOR SEGMENT TABLE IS RATHER HAIRY, SINCE
;;; THE SIZES AND POSITIONS OF ALL FIELDS IN EACH WORD ARE DEPENDENT ON THE
;;; SEGMENT SIZE. THE LOW ORDER <22-<SEGLOG-5>> BITS OF EACH ENTRY CONTAIN
;;; THE HIGH-ORDER BITS OF THE ADDRESS OF THE BLOCK OF BITS TO BE USED IN MARKING
;;; THAT SEGMENT. (NOTE THAT THE OMITTED LOW-ORDER BITS OF THIS ADDRESS ARE
;;; ZERO ANYWAY.) THESE ADDRESS BITS ARE IN THIS STRANGE RIGHT-ADJUSTED POSITION
;;; FOR THE CONVENIENCE OF THE GCMARK ROUTINE (Q.V.). NOT ALL SEGMENTS HAVE
;;; BIT BLOCKS; THOSE WHICH DO NOT HAVE A BIT BLOCK HAVE ZERO IN THIS FIELD.
;;; TO THE LEFT OF THIS BIT BLOCK ADDRESS FIELD IS A FIELD OF <22-SEGLOG> BITS;
;;; THIS CONTAINS THE NUMBER OF THE NEXT SEGMENT IN THE TABLE OF THE SAME TYPE.
;;; (NOT ALL SEGMENTS ARE LINKED IN THIS WAY; THOSE SEGMENTS WHICH ARE NOT
;;; LINKED TO ANOTHER ONE HAVE THIS FIELD ZERO.) THE HIGH-ORDER BIT (BIT 4.9)
;;; IS ONE IFF GCMARK SHOULD MARK (NOT NECESSARILY WITH A BIT BLOCK) THE CONTENTS
;;; OF THE SEGMENT. THE BIT 22 BIT POSITIONS TO THE LEFT OF THE HIGH-ORDER
;;; BIT OF THE BIT BLOCK ADDRESS FIELD IS ONE IFF GCMARK SHOULD MARK FROM THE
;;; CDR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY IF BIT 4.9
;;; IS ONE. THE BIT TO THE RIGHT OF THE CDR BIT IS ONE IFF GCMARK SHOULD ALSO
;;; MARK FROM THE CAR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY
;;; IF THE CDR BIT IS ONE. THESE THREE BITS MUST BE IN THESE EXACT POSITIONS,
;;; AGAIN FOR THE CONVENIENCE OF GCMARK (Q.V.). THE OTHER BITS IN EACH WORD
;;; ARE SO ARRANGED AS TO USE UP FREE BITS FROM THE LEFT END OF THE WORD, PACKED
;;; IN AROUND THE THREE BITS ALREADY DESCRIBED. THESE OTHER BITS INDICATE WHETHER
;;; OR NOT THE SEGMENT CONTAINS VALUE CELLS, SYMBOLS, OR SARS.
GCBMRK==400000 ;THESE ARE ALL LEFT HALF FLAGS
GCBCDR==1←<22-<SEGLOG-5>-1>
GCBCAR==GCBCDR←-1
GCB==1,,525252 ;FOR BIT TYPEOUT MODE
ZZZ==400000
GCBFOO==0
IRP NAM,,[VC,SYM,SAR]
ZZZ==ZZZ←-1
IFN ZZZ&GCBCDR, ZZZ==ZZZ←-2
GCB!NAM==ZZZ
GCBFOO==GCBFOO\ZZZ
TERMIN
IFN HNKLOG,[
IFG GCBSAR-GCBCAR, ZZZ==GCBCAR
GCBHNK==0
IRP X,,[4,8,16,32,64,128,256,512,1024]
IFE .IRPCNT-HNKLOG, .ISTOP
ZZZ==ZZZ←-1
CONC GCBH,\.IRPCNT+1,==ZZZ
GCBHNK==GCBHNK\ZZZ
TERMIN ;GCBHNK BITS GUARANTEED CONSECUTIVE AND BELOW GCBCAR
.SEE GCMARK
] ;END OF IFN HNKLOG
GCST: ;GC SEGMENT TABLE
IFE ITS, BLOCK NSEGS ;FOR DEC-10, THE GCST TABLE IS SET UP AT RUN TIME BY INIT.
IFN ITS,[
IF1, BLOCK NSEGS
IF2,[
BTB.==BTBLKS ;LOCATION COUNTER FOR ASSIGNING BIT BLOCKS
$GCST ZER,,,0
IFN LOBITSG, $GCST BIT,,,0
$GCST ST,,,0
$GCST SYS,,,0
$GCST SAR,L,,GCBMRK+GCBSAR
$GCST VC,,,GCBMRK+GCBVC
$GCST XVC,,,0
$GCST IS2,L,,0
$GCST SYM,L,,GCBMRK+GCBSYM
$GCST XXA,L,,0
$GCST XXZ,,,0
$GCST SY2,,,0
$GCST PFX,,,0
$GCST PFS,,,0
$GCST PFL,,,0
$GCST XXP,,,0
$GCST IFS,L,B,GCBMRK+GCBCDR+GCBCAR
$GCST IFX,L,B,GCBMRK
$GCST IFL,L,B,GCBMRK
IFN BIGNUM, $GCST BN,L,B,GCBMRK+GCBCDR
LXXBSG==LXXASG
$GCST1 NXXBSG,XXB,L,,0
IFE LOBITSG, $GCST BIT,,,0
$GCST BPS,,,0
$GCST NXM,,,0
$GCST FXP,,,0
$GCST XFXP,,,0
$GCST FLP,,,0
$GCST XFLP,,,0
$GCST P,,,0
$GCST XP,,,0
$GCST SP,,,0
$GCST XSP,,,0
$GCST SCR,,,0
.HKILL GS.ZER
IFN GCST+NSEGS-., WARN \.-GCST,[=WRONG GC SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END OF IF2
] ;END OF IFN ITS
PAGEUP
SPCTOP ST,,[SEGMENT TABLE]
10$ $HISEG
10$ HILOC==. ;ORIGIN OF HIGH SEGMENT
10% SPCBOT SYS
SUBTTL BEGINNING OF PURE LISP SYSTEM CODE
PGBOT ERR
BPURPG==. ;BEGINNING OF PURE PAGES FOR INSERT FILE PAGE AND PURIFY
$$$NIL: 777300,,VNIL ;SYMBOL BLOCK FOR NIL
0,,$$NIL ;ALWAYS KEEP ON FIRST PURE SYSTEM PAGE
;;@ ERROR 43 ERROR MSGS AND HANDLERS
SUBTTL ERROR UUO HANDLERS
.SEE EPRINT
EPRNT1:
IFE QIO,[
PUSHJ P,SAVX3 ;ERROR PRINT
PUSHJ P,TLPRINT
JRST RSTX3
] ;END OF IFE QIO
IFN QIO,[
PUSHJ P,SAVX5 ;ERROR PRIN1
PUSH P,AR1 .SEE ERROR3
SKIPN V%PR1
JRST EPRNT2
HRRZ B,VMSGFILES
CALLF 2,@V%PR1
JRST EPRNT3
EPRNT2: HRRZ AR1,VMSGFILES
TLO AR1,200000
PUSHJ P,$PRIN1
EPRNT3: STRT 17,[SIXBIT \ !\]
POP P,AR1
JRST RSTX5
] ;END OF IFN QIO
ERROR1: MOVEM TT,UUTTSV
MOVEM UURSV
JSP TT,ERROR9 ;PROCESS A LISP ERROR
JRST EROR1A ; (LERR AND LER3)
Q% SKIPE VJPG ;***** CROCK!!!!! FOR JPG *****
Q% JRST EROR1Q
Q% SKIPE VERRSET
Q% SKIPN ERRTN
Q% EROR1Q: SETZM TTYOFF
Q% JSR ERROR3
Q$ MOVEI T,-2(P) ;T POINTS TO ERRFRAME
Q$ HRRZ AR1,VMSGFILES
Q$ PUSHJ P,ERROR3
EROR1A: MOVEI A,NIL
JRST 2,@[ERRRTN]
SUBTTL ERRFRAME FORMATS
;;; FORMAT OF ERRFRAME:
;;;
;;; [1] NORMAL TYPE ERROR (ERINT, LERR, ETC.)
;;; <SP>,,<RETURN FROM ERROR IF ERINT>
;;; $ERRFRAME
;;; <UUO> ;ADDRESS OF MSG IN RIGHT HALF
;;; <S-EXP> ;FOR ERINT, LER3
;;;
;;; [2] ERRBAD TYPE ERROR (ILL MEM REF, ETC.)
;;; <SP>,,<ADDRESS WHERE ERROR OCCURRED>
;;; $ERRFRAME
;;; 0,,<ADDRESS OF MSG>
.SEE ERRBAD
ERROR9: PUSH P,UUOH
HRLM SP,(P)
PUSH P,[$ERRFRAME] ;RANDOMNUMBER,,EPOPJ
PUSH P,40 ;CANNOT HAVE LH = 0; SEE ERRPRINT
PUSH P,A
LERFRAME==4 ;LENGTH OF ERRFRAME - WATCH THIS IN CASE OF CHANGE
PION ; - SHOULD BE LESS THAN 20 (FOR R70 REFS - SEE ERRV)
EROR9A: SKIPN PSYMF
SKIPE ERRSW
JRST 1(TT)
JRST (TT)
ERRRTN: SETZM NOQUIT
PION ;ERROR PROCESSING RETURNS HERE TO RECOUP BACK
PUSH P,A
Q$ SKIPL A,UNREAL
PUSHJ P,CHECKU ;CHECK FOR ANY DELAYED "REAL TIME" INTS
POP P,A
ERR2: SKIPE ERRTN ;TO TOPLEVEL, OR BREAK OUT OF AN ERRSET
JRST ERR0 ;GO BREAK UP AN ERRSET
LSPRT0: PUSH FXP,CATRTN ;RETURN TO TOP LEVEL FROM LISP ERROR
JSP A,ERINI0
POP FXP,CATRTN ;GJS NEEDS TO THROW FROM A *RSET-TRAP
CLSPRET: SETZ A,LSPRET
SKIPE B,V.TRAP ;INVOKE *RSET-TRAP
CALLF 1,(B)
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JUMPE A,LSPRET
HRRZ T,C2
HRRZ T,1(T)
CAIE T,HACENT ;MEANS BUG ON ERRLIST
JRST LSPRET
MOVE A,VERRLIST
PUSHJ P,NCONS
MOVEI B,QERRLIST
PUSHJ P,XCONS
PUSH P,CLSPRET
FAC [POSSIBLY FELONIOUS ERRLIST - PLEASE INSPECT BEFORE PROCEEDING!]
SUBTTL ERINT, SERING, LERR, LER3
;ERROR3: 0 ;PRINT OUT ERROR MESSAGE FOR ORDINARY
; LISP ERRORS (LERR, LER3, ERINT, SERINT)
Q% EROR3A:
Q$ ERROR3: ;FOR QIO, CALLED VIA PUSHJ P,ERROR3
;POINTER TO $ERRFRAME IN T
Q$ HRLI AR1,200000 ;OUTPUT FILES LIST FOR MSG IN AR1
Q% LDB TT,[331100,,-1(P)] ;P HAS BEEN STACKED UP BY ERROR9
Q$ LDB TT,[331100,,1(T)] ;P HAS BEEN STACKED UP BY ERROR9
JUMPE TT,EROR3C ;ERRBD2 PUSHS MSG WITH NO LERR OPERATION
Q$ HRRZ A,2(T) ;MUST FETCH THE S-EXPRESSION TO PRINT
Q$ STRT AR1,[SIXBIT \↑M;!\] ;PRECEDE MSG WITH A ";"
CAIE TT,LERR←-33 ;LERR DOESN'T PRINT AN S-EXP
PUSHJ P,EPRINT
CAIN TT,SERINT←-33 ;SERINT HAS AN S-EXP MSG
JRST EROR3F
Q% LDB A,[270400,,-1(P)] ;IF IT IS LERR OR LER3, THEN
Q$ LDB A,[270400,,1(T)] ;IF IT IS LERR OR LER3, THEN
CAIE TT,ERINT←-33 ; A NON-ZERO AC FIELD MEANS
JUMPN A,EROR3F ; THE MSG IS AN S-EXP
EROR3C:
Q% STRT @-1(P) ;NOTE THAT THIS CLOBBERS ALL UUOH LEVEL VARS
Q$ STRT AR1,@1(T) ;NOTE: THIS CLOBBERS UUOH LEVEL VARS
EROR3E: STRT AR1,STRTCR
Q% JRST 2,@ERROR3
Q$ POPJ P,
EROR3F:
Q% HRRZ A,-1(P) ;SERINT IS ERINT WITH S-EXPRESSION MSG
Q% PUSHJ P,PRINC
Q$ HRRZ A,1(T)
Q$ PUSHJ P,$PRINC
JRST EROR3E
IFE QIO,[
;ERROR4: 0 ;PRINT ERROR MESAGE FOR ERRBAD TYPE ERRORS
EROR4A: STRT [SIXBIT \↑M;!\] ;SAVES T, FORTUNATELY
HRRZ TT,-1(T)
STRT @1(T) ;MAIN PART OF ERR MSG PRINTED HERE
STRT [SIXBIT \ FROM LOCATION !\]
PUSH FXP,TT
MOVEI R,TYO
PUSHJ P,PRINL4 ;LOSING PC PRINTED HERE
POP FXP,B
STRT [SIXBIT \↑M;PROGRAM TRAPPED WHILE IN !\]
PUSHJ P,ERRADR ;PRINT NAME OF LOSING FUNCTION HERE
PUSHJ P,ITERPRI
JRST 2,@ERROR4
] ;END OF IFE QIO
IFN QIO,[
;;; PRINT OUT ERROR MESSAGE FOR ERRBAD TYPE ERROR.
;;; OUTPUT FILES FOR MESSAGE IN AR1.
;;; POINTER TO $ERRFRAME IN T.
ERROR4: TLO AR1,200000 ;NO TTY
STRT AR1,[SIXBIT \↑M;!\]
STRT AR1,@1(T)
STRT AR1,[SIXBIT \ FROM LOCATION !\]
HRRZ TT,-1(T)
HRLM TT,(P)
HRROI R,$TYO
PUSHJ P,PRINL4
STRT AR1,[SIXBIT \↑M;PROGRAM TRAPPED WHILE IN !\]
HLRZ B,(P)
PUSHJ P,ERRAD1
STRT AR1,STRTCR
POPJ P,
] ;END OF IFN QIO
;;; PROCESS ERINT/SERINT CORRECTABLE INTERRUPTS
ERROR5: MOVEM TT,UUTTSV
MOVEM UURSV
SKIPN ERRTN ;ALLOW USER INTERRUPT TO RUN,
JRST EROR5F ; EVEN IF INSIDE AN ERRSET,
SKIPN VERRSET ; IF THE ERRSET BREAK IS SET
JRST ERROR1 ;OTHERWISE, JUST DO NORMAL ERROR
EROR5F: LDB TT,[270400,,40]
CAIGE TT,NERINT ;TT HAS AC FIELD FROM UUO
SKIPN VUDF(TT)
JRST ERROR1 ;CONVERT TO LER3 IF NOT ENABLED
MOVEI T,ERRV ;NORMAL XIT FROM CODE BELOW IS POP2J,
Q$ CAIE TT,<%IOL←-27>&17 ;IO-LOSSAGE
CAIN TT,<%FAC←-27>&17 ;FAIL-ACT
MOVEI T,EVAL.A
EROR5A: PUSH FXP,T
MOVEI T,(TT) ;SAVE AC NUMBER FOR BELOW
JSP TT,ERROR9 ;PUSH AN ERROR FRAME
JFCL
MOVEI A,(A)
PUSH FXP,T
JSP T,PDLNMK
Q% POP FXP,T
Q% CAIG T,<%UGT←-27>&17 ;LISTIFY ONLY FOR UDF, UBV, WTA, AND UGT
Q$ EXCH D,(FXP)
Q$ CAIG D,<%UGT←-27>&17
PUSHJ P,ACONS
PUSH P,A ;FOR GC PROTECTION ONLY
Q% MOVSI A,(A)
Q% HRRI A,ERSTBK+1(T)
Q$ TRO D,2000 ;ERINT SERIES USER INTERRUPT
Q$ HRLI D,(A)
MOVE TT,UUTTSV
MOVE T,UUTSV
PUSHJ P,UINT
Q$ POP FXP,D
SUB P,R70+1 ;GC PROTECTION NO LONGER NEEDED
JUMPE A,EROR6A
PUSH FXP,TT
SKOTT A,LS
JRST EROR6A
POP FXP,TT
HLRZ A,(A) ;IF ATOM RETURNED, THEN CRAP OUT
;OTHERWISE, RETURNED VALUE IS LIST OF
POPJ FXP, ;CORRECT QUANTITY MUST GO TO EVAL.A OR ERRV
EROR6A: MOVE A,(P) ;RESTORE A
MOVEI TT,ERROR1+1 ;USER DIDN'T SUPPLY SUITABLE VALUE
JRST EROR9A ;SO ERROR OUT
ERRV: SUB P,R70+LERFRAME-1 ;CLEAR OUT ALL BUT RETURN ADDRESS
POPJ P,
IFN QIO,[
;;; IOJRST UUO DECODER. USAGE:
;;; .CALL FOO ;OR .OPEN, OR WHATEVER
;;; IOJRST N,FOO
;;; IOJRST CAUSES A TRANSFER TO FOO AFTER PUTTING IN
;;; C THE ADDRESS OF A SIXBIT STRING INDICATING THE
;;; ERROR MESSAGE. THIS MESSAGE MAY BE GIVEN TO ERINT
;;; OR LER OR WHATEVER. N IS THE NUMBER OF THINGS ON P
;;; ABOVE THE RETURN ADDRESS - THIS IS A CROCK SO THAT
;;; IOJRST CAN STICK THE ADDRESS OF A RESTORATION ROUTINE
;;; ON THE PDL. THIS IS NECESSARY BECAUSE IN ITS, IOJRST
;;; GETS THE ERROR MESSAGE FROM THE ERR DEVICE AND STICKS
;;; THE SIXBIT ON FLP. SHOULD BE USED ONLY WITH USER
;;; INTERRUPTS TURNED OFF.
ERRIOJ: PUSH P,A ;SAVE ACS
PUSH P,B
JSP T,NPUSH-2
LDB A,[270400,,40] ;GET N
ADDI A,2 ;ADD 2 FOR PUSHED ACS
MOVEI C,(P)
ERIOJ1: MOVE B,-2(C) ;SHUFFLE PDL
MOVEM B,(C)
SUBI C,1
SOJG A,ERIOJ1
MOVEM FLP,-1(C) ;SAVE CURRENT FLP POINTER
MOVEI A,ERIOJ9 ;RESTORATION ROUTINE
MOVEM A,(C)
MOVEI C,1(FLP) ;ADDRESS OF MESSAGE
PUSH FXP,T
.SUSET [.RBCHN,,T]
.CALL ERSTAT
.VALUE
TLNE T,-1
JRST ERIOJ0
PUSH FLP,[SIXBIT \RANDOM\] ;AVOID LOSING "ISE0"
PUSH FLP,[SIXBIT \ ERROR\] ; ERROR MESSAGE
PUSH FLP,R70
MOVSI B,(440600,,(FLP))
JRST ERIO4A
ERIOJ0: MOVEI A,77
ERIOJ5: .CALL ERRDEV
JRST ERIOJ6
ERIOJ2: PUSH FLP,R70 ;NEW WORD FOR MESSAGE
MOVSI B,(440600,,(FLP)) ;BYTE POINTER
ERIOJ3: .IOT TMPC,A ;GET CHAR OF MESSAGE
SUBI A,40
JUMPL A,ERIOJ4 ;CONTROL CHAR TERMINATES MSG
IDPB A,B
TLNE B,770000
JRST ERIOJ3
JRST ERIOJ2
ERIOJ4: .CLOSE TMPC, ;CLOSE RANDOM CHANNEL
ERIO4A: HRRZ A,UUOH
LDB T,[271500,,-2(A)]
CAIE T,.CALL←-27 ;DID THE IOJRST FOLLOW A .CALL?
JRST ERIOJ8
HRRZ T,-2(A)
MOVE T,1(T) ;GOBBLE UP THE SIXBIT NAME
IDPB NIL,B ;STICK THE STRING " <SIXBIT>"
MOVEI A,'< ; AFTER THE ERROR MESSAGE
IDPB A,B
MOVEI A,6
ERIO4G: ROT T,6
TRNE T,77
IDPB T,B
SOJG A,ERIO4G
MOVEI A,'>
IDPB A,B
ERIOJ8: MOVEI A,'! ;! TERMINATES MESSAGE FOR STRT
IDPB A,B
ERIOJ7: POP P,B
POP P,A
POP FXP,T
JRST @40 ;THAT'S 40, NOT UUOH!!!
ERIOJ6: MOVEI B,30.
TRNN A,7
.SLEEP B,
SOJGE A,ERIOJ5
MOVEI C,[SIXBIT \*** I/O SCREW ***!\]
JRST ERIOJ7
ERSTAT: SETZ
SIXBIT \STATUS\ ;GET I/O CHANNEL STATUS
,,T ;CHANNEL NUMBER
402000,,T ;STATUS WORD
ERRDEV: SETZ
SIXBIT \OPEN\ ;OPEN FILE
1000,,TMPC ;TEMPORARY CHANNEL
,,[SIXBIT \ERR\] ;ERR DEVICE
1000,,3 ;3 = DECODE STATUS WORD
400000,,T ;THIS IS THE STATUS WORD
ERIOJ9: POP P,FLP ;RESTORE FLP
POPJ P,
] ;END OF IFN QIO
SUBTTL HAIRY PDL OVERFLOW HANDLER FOR DEC-10
IFN D10,[
PDLOV: HLRZ A,NOQUIT
JUMPN A,GCPDLOV ;PDL OV IN GC - LOSE, LOSE, LOSE!!!
MOVE A,.JBTPC"
MOVEM A,IPCLOK
PDLOV1: JUMPGE P,RPOV
JUMPGE SP,SPOV
JSR INTWAIT
JFCL
JUMPGE FLP,[LERR POVFLP]
JUMPL FXP,[LERR [SIXBIT \USER PDL OVERFLOW!\]]
XPOV: HRRZ A,OFXC2 ;CHECK TO SEE IF ALREADY OPERATION IN OVERFLO AREA
CAIGE A,(FXP)
JRST XPOV1
ADD FXP,[-LOFXPDL,,0] ;SO INCREASE PDL LENGTH BY OVERFLO ALLOTMENT
LERR POVFXP ;ORDINARY ERROR - TRAPPABLE
XPOV1: MOVEI B,POVFXP
JRST PDLOV5 ;MUST TAKE A LITTLE DRASTIC ACTION
SPOV: SUB SP,R70+1
HRRZ A,OSC2 ;UNDO THE CURRENT BATCH OF BINDINGS
SUBI A,(SP)
HRRZ TT,SPSV ;THAT CAUSED THE OVERFLO
PUSHJ P,UBD
JUMPL A,SPOV1
ADD SP,[-LOSPDL,,0]
LERR POVSPDL
SPOV1: SKIPN ERRTN ;IF NOT ERRSET, THE UNDO BACK TO TOP LEVEL
PUSHJ P,ERRPOP ;SO THAT *RSET-TRAP CAUSES NO OVERFLO
MOVEI B,POVSPDL
JRST PDLOV5
RPOV: HRRZ A,OC2
CAIGE A,(P)
JRST RPOV7
ADD P,[-LOPDL+2,,0] ;2 EXTRA, FOR CASES WHERE WE NEED P
LERR POVPDL ; UNDER PIOF, E.G. SPOV
RPOV7: MOVE P,OC2
MOVEI B,POVPDL ;FALL THROUGH TO PDLOV5!!!
] ;END OF IFN D10
PDLOV5: PION
STRT UNRECOV
STRT (B)
SKIPN ERRTN ;BACK TO TOPLEVEL IF NOT ERRSET
JRST LSPRET
JSP T,GOBRK ;BREAK UP THE ERRSET, AND SEE IF
MOVEI A,NIL
HRRZ TT,OFXC2 ;ENOUGH PDL SPACE WAS RELEASED
HRRZ D,OSC2 ;THEREBY. IF NOT, THEN DO MAJOR
CAILE D,(SP) ;RESTART
CAIG TT,(FXP)
JRST PDLOV6
HRRZ D,OC2
HRRZ TT,OFLC2
CAILE D,(P)
CAIG TT,(FLP)
JRST PDLOV6
JRST (T) ;HERE IS ERRSET'S ERROR EXIT
PDLOV6: SETZM TTYOFF
MOVE P,C2
PUSHJ P,ERRPOP
STRT MESMAJ
JRST LISPGO ;BIG RESTART
SUBTTL ILLEGAL OPERATION AND MEMORY VIOLATION HANDLER
IFE QIO,[
;;; "UNRECOVERABLE" AND MACHINE TRAP ERRORS ARE PROCESSED HERE
ERRBAD: MOVEI A,0 ;"BAD" ERROR
MOVE TT,UUOH
ERRBD1: AOJA TT,ERRBD2
PARERR: MOVEI A,5
JRST PPGI4
ERRILO: TDZA A,A
INTILM: MOVEI A,3
PPGI4:
10% MOVE TT,IPCLOK
10$ MOVE TT,.JBTPC"
ERRBD2:
MOVEI R,-1(TT) ;INTERRUPTS LEAVE PC ADVANCED BY ONE
MOVE B,ERRSW
HRRZ TT,C2
HRRZ T,SC2
CAIGE TT,(P)
CAIG T,(P)
JSP TT,ERRBD3 ;P HAS BEEN CLOBBERED; VERY BAD INDEED!
HRLM SP,R
PUSH P,R ;SP,,ADDR WHERE ERROR HAPPENED
PUSH P,[$ERRFRAME] ;ERROR-FRAME-MARKER
PUSH P,ERBMSG(A) ;0,,ADDRESS-OF-ERROR-MESSAGE
SETZM NOQUIT
JUMPE B,ERRBD4
SETZM TTYOFF
MOVEI T,-1(P)
JSR ERROR4 .SEE EROR4A
ERRBD4: HRRZ T,C2
ADDI T,3
CAIE T,(P)
JRST EROR1A
SETZM TTYOFF
STRT [SIXBIT \↑M;SYSTEM PDL CLOBBERED#!!\]
STRT MESMAJ
JRST LISPGO
ERRBD3: MOVE P,C2
MOVEI B,NIL
JRST (TT)
ERBMSG: [SIXBIT \ILGL MACHINE OPERATION!\]
[SIXBIT \UNDEF FUNC CALLED!\]
10% [SIXBIT \JRST TO NIL (LOC 0)!\]
IFN TENEX+D10, [SIXBIT \QUACK!\] ;SHOULDN'T HAPPEN
10X WARN [THINK ABOUT THIS]
[SIXBIT \ILGL MEMORY REFERENCE!\]
[SIXBIT \ATTEMPT TO WRITE ON PURE PAGE!\]
[SIXBIT \PARITY ERROR!\]
IFN ITS,[
UUOGL1: SETZ A, .SEE UUOGLEEP
HRRZ TT,UUOGLEEP ;GET ADDRESS OF BAD UUO
CAIE TT,1
JRST ERRBD2 ;RANDOM ILLEGAL OP
HRRZ TT,JPCSAV ;OOPS, IT CAME FROM NIL!
MOVEI A,2 ;SUPER LOSER
AOJA TT,ERRBD2
] ;END OF IFN ITS
] ;END OF IFE QIO
IFN QIO,[
IFN ITS,[
ERRBAD: MOVE T,UUTSV
MOVEM D,ERRSVD
SETZM JPCSAV ;TOO LATE TO GET JPC
MOVE D,UUOH
JRST UUOGL2
UUOGL1: MOVEM D,ERRSVD
MOVE D,UUOGLEEP
UUOGL2: SUBI D,THIRTY+5 ;SEE IF LOSING INSTRUCTION WAS AN ≠X
TRNN D,-1
JRST $XLOST
ADDI D,THIRTY+5-1 ;ELSE MOVE PC BACK TO LOSING INST
SKIPN VMERR ;SKIP IF USER HANDLER
JRST UUOGL7
PUSH FXP,ERRSVD ;YES, SET UP USER INTERRUPT
PUSH FXP,D
HRLI D,(D)
HRRI D,UIMILO ;ILLEGAL OPERATION
PUSHJ P,UINT
POP FXP,ERRSVD
POP FXP,D
JRST 2,@ERRSVD ;RESTORE MACHINE FLAGS
UUOGL7: EXCH D,ERRSVD ;NO USER HANDLER
.CALL UUOGL8 ;CRAP OUT TO DDT
.VALUE
UUOGL8: SETZ
SIXBIT \LOSE\ ;TELL DDT WE'RE LOSING
1000,,1+.LZ %PIILO ;ILLEGAL OPERATION
400000,,ERRSVD ;NEW PC
] ;END OF IFN ITS
] ;END OF IFN QIO
SUBTTL MISCELLANEOUS ERROR ROUTINES
UUONVE: PUSHJ P,NCONS
MOVEI B,QNUMBERP
PUSHJ P,XCONS
FAC [NUMBER FUNCTION RETURNED NON-NUMERIC VALUE!]
JRST UUONVL
SASERR: EXCH A,B
WTA [BAD ALIST - ASSOC!]
EXCH A,B
JRST SAS4
RMPRER: CALLF 2,QLIST ;LOSER HAS TRIED TO REMOVE
PUSHJ P,NCONS ;THE VALUE CELL OF SOME
MOVEI B,QREMPROP ;IMPORTANT SYSTEM ATOM
PUSHJ P,XCONS
%FAC EMS24
UUOMER: HRRZ A,40
LER3 [SIXBIT \ - MACRO NOT PERMITTED IN UUO CALL!\]
UUOFER: HRRZ A,40
LER3 [SIXBIT \ - WRONG NUMBER OF ARGS SUPPLIED BY UUO CALL!\]
IFN BIGNUM,[
REMAIR: WTA [FLONUM ARG TO REMAINDER!]
JRST -4(T)
] ;END OF IFN BIGNUM
UNOVER: TLNN T,100
OVFLER: LERR [SIXBIT \ARITHMETIC OVERFLOW!\]
UNFLER: LERR [SIXBIT \ARITHMETIC UNDERFLOW!\]
ER2: LERR MES3 ;CONTEXT ERROR WITH DOT NOTATION -READ
ER3: LERR [SIXBIT \BLAST? - READ!\]
ER4: LERR [SIXBIT \GO OUT OF CATCH-BREAK DAMN#!!\]
RDNMER: LERR [SIXBIT \NUMERIC OVFLO - READ!\]
ADEAD: JFCL ;PUSHJ OR JRST THROUGH DEAD ARRAY PTR
MOVEI A,ARQLS ;COULD ALSO GET HERE VIA ACALL/AJCALL
FAC [ARRAY DEFINITION LOST!]
EG1: UGT [NOT SEEN AS PROG TAG!]
JRST GO2
INTNCO: PUSH P,A ;INTERN CRAP-OUT
MOVEI A,OBARRAY
EXCH A,VOBARRAY
UNLOCKI
PUSHJ P,BADOB
POP P,A
JRST INTRN4
BADOB: FAC [BAD VALUE FOR OBARRAY!]
DFPER: POP P,A
WTA [WRONG FORMAT - DEFPROP!]
JRST DEFPROP
DEFNER: POP P,A
WTA [WRONG FORMAT - DEFUN!]
JRST DEFUN
NCNCER: WTA [NON-LIST - NCONC!]
JRST .NCONC
APPERR: WTA [NON-LIST - APPEND!]
JRST .APPEND
PNGE:
PNGE1: %WTA NASER
JRST -2(T)
NASER: SIXBIT \ATOMIC SYMBOL REQUIRED!\
SBADSP: SIXBIT \ BAD SPACE TYPE - STATUS!\
;;; INCREDIBLE CROCK TO CONSTRUCT AN ERROR MESSAGE
;;; CONTAINING THE NAME OF THE APPROPRIATE CAR/CDR FUNCTION.
CA.DER: PUSH FXP,[SIXBIT \ILLEGA\]
PUSH FXP,[SIXBIT \L DATU\]
PUSH FXP,[SIXBIT \M - CX\]
PUSH FXP,[SIXBIT \R!!!! \]
CA.DE1: TRNN T,776
JRST CA.DE2
ROT T,-1
JRST CA.DE1
CA.DE2: MOVEI D,-1(FXP)
HRLI D,060600
CA.DE3: ROT T,1
MOVEI TT,'A
TRNE T,1
MOVEI TT,'D
IDPB TT,D
TRNN T,400000
JRST CA.DE3
MOVEI TT,'R
IDPB TT,D
%WTA -3(FXP)
SUB FXP,R70+4
JRST CR1A
NILSETQ: PUSH P,A ;SOME NERD TRIED TO SETQ NIL, MAYBE?
PUSH P,CPOPAJ
CAIE T,VNIL
JRST TSETQ ;NO, 'TWAS REALLY A TSETQ, MAYBE?
MOVEI A,QNILSETQ
%FAC NIHIL
TSETQ: CAIE T,VT
JRST XSETQ ;NO, I DON'T KNOW WHAT IT WAS!
MOVEI A,QTSETQ
%FAC VERITAS
XSETQ: HRLM T,QXSET1 ;HAND VALUE CELL (?) TO LOSER
MOVEI A,QXSETQ
%FAC PURITAS
STORE5: HRRZ A,-1(P)
%WTA [SIXBIT \DIDN'T EVAL TO GOOD ARRAY REFERENCE - STORE!\]
MOVEM A,-1(P)
JRST STORE7
RPLCA0: WTA [BAD ARG - RPLACA!]
JRST RPLACA
RPLCD0: WTA [BAD ARG - RPLACD!]
JRST RPLACD
RPLCA1: WTA [PURE ARG - RPLACA!]
JRST RPLACA
RPLCD1: WTA [PURE ARG - RPLACD!]
JRST RPLACD
%ARR0A: WTA [WRONG TYPE ARRAY - ARRAYCALL!]
JRST %ARR0B
%ARR0: WTA [NOT ARRAY POINTER!]
%ARR0B: MOVEM A,1(D)
JRST %ARR7
BG% FASBNE: LERR [SIXBIT \FASL FILE HAS BIGNUMS, BUT THIS LISP DOESN'T - CAN'T FASLOAD!\]
IFE HNKLOG, FASHNE: LERR [SIXBIT \FASL FILE HAS HUNKS, BUT THIS LISP DOESN'T - CAN'T FASLOAD!\]
LDGETQ: FAC [CAN'T GET DDT SYMBOL - FASLOAD!]
LDXERR: LERR [SIXBIT \IMPROPER VALUE FOR "PURE" - FASLOAD!\]
LDALREADY:
Q% LERR [SIXBIT \ALREADY FASLOADING!\]
Q$ FAC [INCORRECTLY NESTED FASLOAD!]
IBSERR: MOVEI A,IN10
EXCH A,VIBASE
PUSHJ P,NCONS
MOVEI B,QIBASE
PUSHJ P,XCONS
PUSH P,[RD0B1]
FAC [BAD VALUE FOR IBASE!]
BASER: MOVEI A,IN10
EXCH A,VBASE
PUSHJ P,NCONS
MOVEI B,QBASE
PUSHJ P,XCONS
PUSH P,[PRINI]
FAC [BAD VALUE FOR BASE!]
IFE QIO,[
LINELR: SAVE A B
MOVE A,OLINEL
EXCH A,VLINEL
PUSHJ P,NCONS
MOVEI B,QLINEL
PUSHJ P,XCONS
PUSHJ P,LINLR1
RSTR B A
JRST (D)
LINLR1: FAC [BAD VALUE FOR LINEL!]
] ;END OF IFE QIO
IFN USELESS,[
%LVERR: SETZ A,
EXCH A,V%LEVEL
PUSHJ P,NCONS
MOVEI B,Q%LEVEL
PUSHJ P,XCONS
PUSH P,[%LVCHK]
FAC [BAD VALUE FOR PRINLEVEL!]
%LNERR: SETZ A,
EXCH A,V%LENGTH
PUSHJ P,NCONS
MOVEI B,Q%LENGTH
PUSHJ P,XCONS
PUSH P,[%LNCHK]
FAC [BAD VALUE FOR PRINLENGTH!]
] ;END OF IFN USELESS
SUBTTL A PANDORA'S BOX OF ERROR MESSAGES
NIHIL: SIXBIT \NIHIL EX NIHIL - DON'T SETQ NIL!\
VERITAS: SIXBIT \VERITAS AETERNA - DON'T SETQ T!\
PURITAS: SIXBIT \PURITAS NECESSE EST - DON'T DO RANDOM BINDINGS!\
POVPDL: SIXBIT \REG PDL OVERFLOW!\
POVFLP: SIXBIT \FLONUM PDL OVERFLOW!\
POVFXP: SIXBIT \FIXNUM PDL OVERFLOW!\
POVSPDL: SIXBIT \SPEC PDL OVERFLOW!\
MESMAJ: SIXBIT \↑M;MAJOR RESTART UNDERTAKEN↑M!\
UNRECOV: SIXBIT \↑M;UNRECOVERABLE !\
FLNMER:
$ARERR: SIXBIT \NON-FLONUM VALUE!\
IARERR:
FXNMER: SIXBIT \NON-FIXNUM VALUE!\
NMV3: SIXBIT \NON-NUMERIC VALUE!\
NMV5: SIXBIT \BIGNUM NOT ACCEPTABLE - NUMVAL!\
CAMMES: SIXBIT \FIXNUM CANT COMPARE TO FLONUM. IN =, <, OR >!\
MES2: SIXBIT \ILLEGAL OBJECT SOMEWHERE OR OTHER - READ!\
MES3: SIXBIT \DOT CONTEXT ERROR!\
MES5: SIXBIT \UNDEFINED FUNCTION OBJECT!\
MES6: SIXBIT \UNBOUND VARIABLE!\
MES14: SIXBIT \NOT INSIDE LEXPR/LSUBR!\
MES15: SIXBIT \ARRAY ACCESS ERROR!\
MES18: SIXBIT \TOO MANY ARGUMENTS SUPPLIED - APPLY!\
MES19: SIXBIT \TOO FEW ARGUMENTS SUPPLIED - APPLY!\
MES20: SIXBIT \WRONG NUMBER OF ARGS TO LSUBR!\
MES21: SIXBIT \WRONG NUMBER OF ARGS TO FSUBR!\
EMS1: SIXBIT \EXTRA CHARS IN LIST - READLIST!\
EMS3: SIXBIT \NOT ENOUGH CHARS IN LIST - READLIST!\
EMS4: SIXBIT \ NON-ASCII VALUED NUMBERS UNACCEPTABLE!\
EMS5: SIXBIT \READ-MACRO CONTEXT ERROR!\
EMS6: SIXBIT \BLAST, MISSING ")"!\
EMS10: SIXBIT \GOT TO TTY INSIDE S-EXP - READ!\
;EMS11: SIXBIT \HOW THE HELL CAN THIS BE?!\ .SEE HHCTB
EMS12: SIXBIT \TOO MANY INTERRUPTS - GO AWAY!\
EMS13: SIXBIT \LOST USER INTERRUPT!\
EMS15: SIXBIT \UNDEFINED FUNCTION IN UUO CALL!\
EMS16: SIXBIT \MORE THAN 5 ARGS!\
EMS18: SIXBIT \FUNCTION UNDEFINED AFTER AUTOLOAD!\
EMS21: SIXBIT \IMPROPER USE OF MACRO - EVAL!\
EMS22: SIXBIT \ILGL GO OR RETURN - NOT INSIDE A PROG!\
EMS24: SIXBIT \DONT REMOVE VALUE PROPERTY FROM SYSTEM ATOM!\
EMS25: SIXBIT \UNEVALUABLE DATUM - EVAL!\
EMS26: SIXBIT \FILE NOT FOUND!\
IFE QIO,[
EMS27: SIXBIT \NO OUTPUT UNIT SELECTED!\
EMS28: SIXBIT \NO READ SOURCE SELECTED!\
]
EMS29: SIXBIT \NO CATCH FOR THIS TAG - THROW!\
EMS31: SIXBIT \INVALID ARG TO GENSYM!\
EMS33: SIXBIT \RANDOM CHAR - TYI!\
EMS34: SIXBIT \NOT SUBR POINTER!\
NW% NONXDV: SIXBIT \NON-EXISTENT DEVICE CHANNEL!\
NW% SCRUDE: SIXBIT \I/O SCREW!\
NW% DEVFUL: SIXBIT \ FULL - DELETE SOME FILE↑MAND TYPE $P TO RESUME↑M!\
OPNLUZ: SIXBIT \↑M;I/O CHANNEL OPEN FAILURE!\
STRTCR: SIXBIT \↑M!\
SUBTTL YET MORE MISCELLANEOUS ERROR ROUTINES
IFE QIO,[
IFE D10,[
; PUTCODE [OPNER]\27+2*MOBIOF,INT,ERR
;;; SHARED ROUTINE FOR AN OPEN THAT LOSES. TRIES TO BE HELPFUL.
OPNER: LDB A,[270400,,-2(T)] ;GIVE OUT MESSAGE FOR ERROR UPON
CAIE A,0 ;ATTEMPTING TO OPEN I/O CHANNEL
CAIL A,NOFCH
.VALUE
CAIN A,LPTC
SETZM LPTON
IFN MOBIOF,[
CAIN A,DISC
SETZM DISPON
] ;END OF IFN MOBIOF
CAIN A,UTOC
SETZM TAPWRT
SKIPN ERRSW
JRST OPNR3
SETZM TTYOFF
.OPEN ERRC,OERRC ;THE ERRC IS ALWAYS RESERVED FOR THE SYSTEM IN NEWIO
JRST OPNR3
OPNER1: .IOT ERRC,A
CAIN A,14
JRST OPNER2
PUSHJ P,TYO
JRST OPNER1
OPNER2: IFE QIO, SETZM ERRSW
OPNR3: LERR OPNLUZ ;I/O CHANNEL OPEN FAILURE
OERRC: SIXBIT \ ERR\
1
; ENDCODE [OPNER]
] ;END OF IFE D10
] ;END OF IFE QIO
IFE QIO,[
UTOER1: SETZM TAPWRT
SETZM UTOOPD
MOVEI A,QUWL
%FAC EMS27
URIOER: SETZM TAPRED
MOVEI A,QURL
%FAC EMS28
IFE D10,[
IOERR: .SUSET [.SIPIRQC,,A]
MOVEM A,INTSV
HRRZ A,INT+1
LDB A,[270400,,-1(A)]
CAIL A,NOFCH
.VALUE
DPB A,[270400,,IOST]
XCT IOST
LDB A,[330400,,A]
CAIN A,11
JRST IODF
CAIN A,4
LERR NONXDV ;NON-EXISTENT DEVICE CHANNEL
CAIE A,10
JRST IOE3
LDB A,[270400,,IOST]
IFN MOBIOF,[
CAIE A,IMXC
CAIN A,OMXC
LERR [SIXBIT \MPX NOT OPENED!\]
] ;END OF IFN MOBIOF
SKIPE INTSV
.VALUE ;LOSING TWO INTERRUPTS AT SAME TIME
PUSH P,INT+1
PUSH P,A
PUSH P,CPOPAJ
.SUSET PINBL
CAIN A,UTIC
JRST URIOER
CAIE A,UTOC
IOE3: LERR SCRUDE ;I/O SCREW
] ;END OF IFE D10
] ;END OF IFE QIO
IFN MOBIOF,[
; PUTCODE [MOBY I/O ERRORS]120,MIO,ERR,UIO
DERR1: SIXBIT \DSLAVE FILE MISSING!\
DERR2: SIXBIT \DISPLAY SLAVE HAS NOT BEEN OPENED!\
DERR3: [SIXBIT \WRONG NUMBER OF ARGS TO SOME FUNCTION - DSLAVE!\]
DALMES: WTA [FLONUM ARG REQUIRED - DISPLAY SLAVE!]
JRST -1(T)
PPBSL4: MOVE A,(P)
WTA [BAD ARG TO SOME DISPLAY FUN!]
JRST PPBSL1
DERR0: LERR [SIXBIT \SLAVE HAS DIED!\]
DERR: LERR [SIXBIT \TOO MANY DISPLAY ITEMS!\] ;TABLE OF ERRORS
LERR [SIXBIT \DISPLAY MEMORY FULL!\] ;RETURNED FROM SLAVE
LER3 [SIXBIT \ UNKNOWN DISPLAY ITEM!\]
LERR [SIXBIT \ENORMOUS VECTOR!\]
LERR [SIXBIT \BAD RELATIVE VECTOR - DSLAVE!\]
LERR [SIXBIT \BAD FUNCTION - DSLAVE!\]
LERR [SIXBIT \340 NOT AVAILABLE!\]
LER3 [SIXBIT \ HAS TOO MANY DISPLAY INFERIORS!\]
; ENDCODE [MOBY I/O ERRORS]
] ;END OF IFN MOBIOF
; PUTCODE [ERRERC]15,ERR,SUS
ERRERC: POP P,A ;LIKE (ERROR MSG ARGS)
LER3 1,@(P)
ERRERO: MOVEI A,(B)
WTA [INVALID ERROR CHANNEL SPECIFICATION!]
JRST ERRERB
ERERER: MOVEI D,Q$ERROR
SOJA T,S2WNAL
; ENDCODE [ERRERC]
; PUTCODE [EVAL.A]7,ERR,EVL,SUS
EVAL.A: SUB P,[LERFRAME,,LERFRAME] ;CLEAR OUT ALL OF ERRFRAME
PUSHJ P,SAVX5 ;SAVE EVERYTING AND EVAL A
PUSHJ FXP,SAV5M1 ;ORDINARY FAIL-ACT ERROR.
PUSHJ P,EVAL
EVAL.1: PUSHJ FXP,RST5M1
JRST RSTX5
; ENDCODE [EVAL.A]
IFE D10\QIO,[
; PUTCODE [IODF]15,ERR,UIO,INT
IODF: PUSHJ P,SAVX5 ;UNFORTUNATELY, INTERRUPTS REMAIN
PUSHJ P,IOGBND ;SHUT OFF HERE. OTHER INTERRUPTS
HRRZ A,UWRT ;MAY BE STACKED IN .IPIRQC
DPB A,[062200,,IODF1]
STRT IODF1
STRT DEVFUL ;DEVICE FULL MESSAGE
.VALUE [ASCII \:VK \]
PUSHJ P,UNBIND
PUSHJ P,RSTX5
SOS INT+1
JRST INTEX1
; ENDCODE [IODF]
] ;END OF IFE D10\QIO
; PUTCODE [.UDT]41,ERR,UIO
.UDT: MOVEI B,(A)
PUSHJ P,FIXP
EXCH A,B
JUMPN B,.UDT2
SKIPN ERRSW
JRST .UDT1
PUSHJ FXP,SAV5
STRT [SIXBIT \↑M;IN !\]
HRRZ B,-NACS(P) ;GET RETURN ADDRESS
PUSHJ P,ERRADR ;AND PRINT OUT FUN THEREFOR
JSP R,RSTR5
.UDT1: UGT [ UNDEFINED COMPUTED GO TAG!]
POPJ P,
.UDT2: SETZM PNBUF
SETZM PNBUF+1
SETZM PNBUF+2
MOVEI C,10.
MOVEI R,.UDT4
MOVE AR1,[440700,,PNBUF]
JUMPGE TT,.+3
MOVNS TT
XCT "-,CTY
PUSHJ P,PRINI9
SETOM LPNF
MOVEI C,(AR1)
JRST RINTERN
; ENDCODE [.UDT]
ESB6: MOVEI D,0
WNAERR: CAMG TT,T
SKIPA TT,[MES19] ;TOO FEW ARGS
MOVEI TT,MES18 ;TOO MANY ARGS
MOVEM B,QF1SB
JUMPN D,WNAER1 ; D ↑= 0 => LISTING ALREADY DONE
PUSH FXP,R
JSP R,LIST1
POP FXP,R
WNAER1: HLRZ B,(P)
PUSHJ P,XCONS
MOVEM A,(P)
PUSH FXP,TT ;ARGSCU DESTROYS TT
PUSHJ P,ARGSCU
POP FXP,TT
JRST QF1A
QF3A: SKIPA TT,[MES19] ;AT THIS POINT, WE CRAP OUT
QF2A: MOVEI TT,MES18
MOVE T,R
JSP R,LIST1
HLRZ B,(P)
JUMPN B,.+2
MOVEI B,QM ;QUESTION MARK!
PUSHJ P,XCONS
EXCH A,(P)
JSP T,%CADR
QF1A: PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
%WNA (TT)
JRST EVAL
UUOH3C: SAVE A B
MOVEI T,EMS18
JRST UUOUE1
UUOH3A: SAVE A B
UUOUER: MOVEI T,EMS15
UUOUE1: MOVNI A,LUUSV ;UNDEFINED UUO CALL
PUSH FXP,UUOH+LUUSV(A)
AOJL A,.-1
PUSH FXP,40
HRRZ A,40
%UDF (T) ;UNDEF FUN IN UUO CALL (OR AFTER AUTOLOAD)
POP FXP,40
MOVEI T,LUUSV
POP FXP,UUOH-1(T)
SOJG T,.-1
HRRZ T,A
JUMPN A,UUOH3B
HRRZ A,40
PUSHJ P,EPRINT
Q% MOVEI A,1
Q% JRST ERRBD1
Q$ LERR [SIXBIT \UNDEFINED FUNCTION CALLED!\]
EPRINT: SKIPN ERRSW ;ERROR PRINTOUT
POPJ P,
JRST EPRNT1
EV3B: SKIPA A,EV0B
EV3A: HLRZ A,AR1
%UDF MES5 ;UNDEFINED FUNCTION OBJECT
JRST EV4B
EV3J: HLRZ A,AR1
%UDF EMS18 ;FN UNDEF AFTER AUTOLOAD
JRST EV4B
IAP2A: TDZA TT,TT ;UNDEFINED FN OBJECT
IAP2J: MOVEI TT,EMS18-MES5 ;FN UNDEF AFTER AUTOLOAD
HLRZ A,(C)
SKIPN A
HRRZ A,(C)
%UDF MES5(TT)
HRRM A,(C)
JRST ILP1
WNAL0: MOVE D,(TT)
TLNE D,1 ;SKIP IF LSUBR
JRST WNAFOSE
WNALOSE: MOVEI TT,MES20 ;USE LSUBR MESSAGE
WNAL2: JSP R,LIST1 ;LISTIFY UP LSUBR ARGS
WNAL1: MOVEI B,(D)
PUSHJ P,XCONS ;CONS FUNCTION NAME ONTO ARG LIST
PUSH P,A
MOVEI A,QM ;USE ? FOR ARGS SPEC
JRST QF1A
STERR: MOVEI D,(F)
WNAFOSE: MOVEI TT,MES21 ;USE FSUBR MESSAGE
JRST WNAL1
IFE QIO,[
LDOERR: UNLOCKI
PUSHJ P,LDFNSET
PUSHJ P,UNBIND
PUSH P,[QFASLOAD]
JRST UFLR1
] ;END OF IFE QIO
FASLNX: SETZM LDXSIZ
FASLNC:
10% Q% .CLOSE DSIC,
10% Q$ HRRZ A,LDBSAR
10% Q$ PUSHJ P,$CLOSE
10$ RELEASE DSIC, ;NICE LONG ERR MSG TO REASSURE MACSYMA LOSERS
LERR [SIXBIT \YOU HAVE RUN OUT OF CORE - FASLOAD!\] ;TOTAL LOSS
LDFERR:
10% Q% .CLOSE DSIC,
10% Q$ HRRZ A,LDBSAR
10% Q$ PUSHJ P,$CLOSE
10$ RELEASE DSIC,
UNLOCKI
MOVE A,LDFNAM
MOVEI B,QFASLOAD
PUSHJ P,XCONS
PUSHJ P,UNBIND
SUB P,R70-LDPRLS+1
FAC [FILE NOT IN FASLOAD FORMAT!]
IFE QIO,[
UNTAER: HRRZ A,(P)
WTA [NEED 2 FILE NAMES IN LIST!]
HRRM A,(P)
JRST (T)
UROER: SETZM UTIOPD
SETZM TAPRED
MOVEI B,QUREAD
JRST UFLER
UAPPER: SKIPA B,[QUAPPEND]
UKLER: MOVEI B,QUKILL
UFLER: UNLOCKI
PUSH P,B
PUSHJ P,SCRFUN
UFLR1: POP P,B
POP P,IUNIT
PUSHJ P,XCONS
%FAC EMS26
UREDER: PUSH P,A
MOVEI A,QURL
SETZM TAPRED
PUSHJ P,[%FAC EMS28]
POP P,A
SKIPN UTIOPD
POPJ P,
AOS TAPRED
JRST URED
] ;END OF IFE QIO
LMBERR: EXCH A,C
MOVE R,T
WTA [BAD LAMBDA LIST!]
MOVE TT,C
JRST IPLMB1
LXPRLZ: LERR [SIXBIT \TOO MANY ARGS TO LEXPR!\]
DOERRE: MOVEI A,(B)
WTA [ BAD END TEST FORM - DO!]
MOVEI B,(A)
JRST DO4C
GETLE: EXCH A,B
GETLE1: WTA [BAD LIST - GETL!]
EXCH A,B
JRST GETL
SETWNA: POP P,A
MOVEI B,QSETQ
PUSHJ P,XCONS
PUSHJ P,NCONS
WNA [WNA - SETQ!]
JRST EVAL
SIGNPE: MOVE A,(P)
WTA [UNRECOGNIZABLE TEST REQUEST - SIGNP!]
MOVEM A,(P)
JRST SIGNP0
PROPER: WTA [BAD ARG - PUTPROP!]
JRST PUTPROP
RMPER0: WTA [BAD ARG - REMPROP!]
JRST REMPROP
LFYER: PUSHJ P,NCONS ;NOT INSIDE LSUBR
MOVEI B,QLISTIFY
PUSHJ P,XCONS ;LET LOSER FIGURE IT OUT
%FAC MES14
GENSY8: %WTA EMS31
PUSH P,A
JRST GENSY7
ARGCM8: WTA [ARG TOO LARGE OR <0 - ARG/SETARG!]
JRST ARGCOM
ARGCM0: MOVEI R,-1(R) ;NOTE: FLUSHES FLAGS IN LEFT HALF!
CAIN R,ARGXX
JRST ARGCM1
CALLF 2,QLIST
MOVEI B,QSETARG
JRST ARGCM2
ARGCM1: PUSHJ P,NCONS
MOVEI B,QARG
ARGCM2: PUSHJ P,ACONS ;LISTIFY AGAIN, WITHOUT LOSING B
PUSHJ P,XCONS
%FAC MES14
PTRCKE: PUSH P,A
MOVEI A,(TT)
%WTA EMS34
MOVEI TT,(A)
POP P,A
JRST PTRCHK
.STOL1: POP P,B
PUSH P,T
FAC [CAN'T STORE INTO NON-ARRAY!]
IFN QIO,[
TYOAGE: WTA [NOT ASCII VALUE!]
JRST TYOARG
GTRDT9: FAC [BAD VALUE FOR READTABLE!]
EOFE: MOVEI A,(AR1)
PUSHJ P,NCONS
MOVEI B,QRDEOF
PUSHJ P,XCONS
PUSHJ P,EOFE1
JUMPE A,EOF5
SKIPE T,EOFRTN ;CLOBBER IN EOF VALUE IF NON-NIL
HRRM A,-LERSTP-1(T) ; AND IF EOF FRAME EXISTS
JRST EOF5
EOFE1: FAC [END OF FILE WITHIN READ!]
] ;END OF IFN QIO
MAPWNA: MOVEI D,QMAPLIST-MAPLIST-1(TT)
SOJA T,WNALOSE
DLT6: CAIE D,MEMBER
SKIPA D,[QDELQ]
MOVEI D,QDELETE
JRST WNALOSE
VALST0: WTA [ VALRET STRING TOO LONG!]
JRST VALSTR
SUSPE: PUSHJ P,NCONS
MOVEI B,QSUSPEND
PUSHJ P,XCONS
FAC [I/O IN PROGRESS - CAN'T SUSPEND!]
GTPDL1: WTA [ NOT PDL POINTER!]
JRST GTPDLP
RAND9: MOVEI D,QRANDOM
S2WNAL: SOJA T,S1WNAL
TYPKER: MOVEI D,QTYIPEEK
S1WNAL: SOJA T,WNALOSE
GRCTIE: EXCH A,B
WTA [NOT VALID READTABLE INDEX!]
EXCH A,B
JRST GRCTI
FRERR: WTA [NOT A FRAME POINTER - FRETURN!]
JRST FRETURN
IFN USELESS*ITS,[
CRSRP2: WTA [BAD CURSOR CODE - CURSORPOS!]
JRST CRSRP3
] ;END OF IFN USELESS*ITS
IFN FUNAFL,[
ALST0: MOVE A,-1(P)
WTA [BAD ALIST - EVAL/APPLY!]
MOVEM A,-1(P)
JRST ALIST
] ;END OF IFN FUNAFL
LFY0: WTA [ARG TOO LARGE - LISTIFY!]
JRST LISTIFY
IFE D10,[
ALCK0: EXCH A,B
WTA [BAD ARG - ALARMCLOCK!]
JRST ALARMCLOCK
] ;END OF IFE D10,
DOERR: POP P,A
WTA [BAD VAR LIST - DO!]
MOVEM A,-2(P)
JRST DO5
DO5ER: MOVEI A,(B)
WTA [EXTRANEOUS STEPPER - DO!]
JRST DO5Q
ATAN.7: LERR [SIXBIT \OVERFLOW/UNDERFLOW IN ATAN!\]
EXP.ER: MOVE D,[EXP.,,[SIXBIT \ARG TOO BIG - EXP!\]]
JRST NUMER
SIN.ER: SKIPA D,[SIN.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - SIN!\]]
COS.ER: MOVE D,[COS.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - COS!\]]
JRST NUMER
SQR$ER: SKIPA D,[SQRT.,,[SIXBIT \NEG ARG - SQRT!\]]
LOG.ER: MOVE D,[LOG.,,[SIXBIT \NON-POS ARG - LOG!\]]
NUMER: JSP T,PDLNMK ;IF ARG WAS A PDL NUM, GET A REAL ONE
%WTA (D) ;COMPLAIN TO LOSER
HLRZS D
JRST 2,@D
IARERR
$ARERR
ARTHER: %WTA @.-1(T)
JRST ARITH
1EQNF: TDZA T,T
1GPNF: MOVEI T,$GREAT-$EQUAL
EXCH A,B
%WTA CAMMES
JRST $EQUAL(T)
2EQNF: TDZA T,T
2GPNF: MOVEI T,$GREAT-$EQUAL
%WTA CAMMES
EXCH A,B
JRST $EQUAL(T)
IFE QIO,[
ER1: MOVEI A,QM
SKIPN TAPRED
JRST ER1A
HRRZ T,UTIBP
SUBI T,4
CAIGE T,UTIB
MOVEI T,UTIB
MOVEI TT,LPNBUF-1(T)
CAILE TT,UTIB+UTBSIZ-1
MOVEI TT,UTIB+UTBSIZ-1
SUBI TT,(T)
HRLI T,PNBUF
BLT T,PNBUF(TT)
SETOM LPNF
PUSHJ P,RINTERN
ER1A: LER3 MES2
] ;END OF IFE QIO
GCMLOSE: HRRZ C,GCMES+NFF(F)
JSR GCRSR
SETOM PANICP
%GCL GCLSMS
SETZM PANICP
POP P,A
SETOM IRMVF ;ON GENERAL PRINCIPLES, GCTWA ONCE
JRST AGC
GCMES: QLIST
QFIXNUM
QFLONUM
BG$ QBIGNUM
QSYMBOL
REPEAT HNKLOG, CONC QHUNK,\.RPCNT+1
QARRAY
QSYMBOL ;FOR SYMBOL-BLOCKS, SIMPLY SAY "SYMBOL"
GCLSMS: SIXBIT \STORAGE CAPACITY EXCEEDED!\
;;; COME HERE WHEN THINGS LOOK REALLY DESPERATE IN GC.
GCLUZ: SKIPN PANICP ;HOPE FOR THE BEST, JPG!
JRST GCMLOSE
SKIPE C,F
HRRZ C,GCMES+NFF(F) ;WELL, IT LOOKS LIKE WE
JSR GCRSR ; HAVEN'T EVEN A SNOBOL'S
SETZM TTYOFF ; CHANCE IN HELL HERE...
JUMPE A,GCLUZ6
PUSHJ P,PRINT ;TELL LOSER HE LOST TOTALLY
GCLUZ3: STRT GCLSMS
STRT [SIXBIT \ BEYOND RECUPERATION!\]
SKIPLE IRMVF
JRST GCLUZ7
MOVEI TT,SPDLORG
CAILE TT,(SP) ;IF WE LOST OUT GC'ING AT TOP
JRST DIE ; LEVEL, WE ARE TOTALLY LOST
GCLUZ4: STRT MESMAJ ;OTHERWISE WE HAVE HALF A CHANCE
PUSHJ P,ERRPOP ; OF FREEING UP SOME STORAGE
JRST LISPGO ; BY UNBINDING SPECIAL VARIABLES
GCLUZ6: STRT [SIXBIT \SYMBOL BLOCK!\]
JRST GCLUZ3
GCLUZ7: SETOM IRMVF
JRST GCLUZ4
GCPDLOV: SETZM TTYOFF
MOVE P,C2
MOVE FXP,FXC2
STRT [SIXBIT \↑M;PDL OVERFLOW WHILE IN GC#!!\]
DIE: STRT [SIXBIT \↑M;YOU HAVE LOST BADLY#!↑M!\]
.VALUE
JRST DIE
SUBTTL ERROR ADDRESS DECODER
IFN QIO,[
ERRADR: HRRZ AR1,VMSGFILES
TLO AR1,200000
ERRAD1: PUSH P,AR1
PUSHJ P,ERRDCD
POP P,AR1
JRST $PRIN1
] ;END OF IFN QIO
Q% ERRADR: PUSH P,CPRIN1
ERRDCD: MOVEI A,QM ;DECODE ADDRESS AS SUBR OR ARRAY
10$ CAIL B,ENDFUN ; PROPERTY OF SOME ATOM
.ELSE CAIGE B,BEGFUN ;ADDRESS 0 ALWAYS GIVES OUT QM - SEE BK1A1B
CPRIN1: POPJ P,PRIN1 ;ERRDCD SAVES T (SEE WNAYOSE)
10$ CAIL B,BEGFUN
10% CAIGE B,ENDFUN
JRST ERRO2E
CAIL B,BBPSSG
CAMLE B,BPSH
POPJ P,
ERRO2E:
10$ MOVEI AR2A,BBPSSG
10% MOVEI AR2A,BEGFUN
LOCKI ;GCGEN IS NOT INTERRUPT SAFE
JSP R,GCGEN
ERRO2Q
UNLKPOPJ
ERRO2Q: SKIPE INTFLG ;LET INTERRUPTS HAPPEN - THIS IS A VERY
JRST ERRO2R ; LONG PROCESS FOR LARGE OBARRAYS!
ERRO2A: HLRZ TT,(D)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2B
HLRZ AR1,(TT)
HRRZ TT,(TT)
CAIN AR1,QLSUBR
JRST ERRO2H
CAIE AR1,QSUBR
CAIN AR1,QFSUBR
JRST ERRO2H
CAIE AR1,QARRAY
JRST ERRO2C
HLRZ AR1,(TT)
HRRZ TT,(AR1)
CAML B,@VBPEND ;IF ARG IS < BPEND, THEN CANT BE AN ARRAY
CAIGE TT,-3(B)
JRST ERRO2B
JRST ERRO2G
ERRO2H: HLRZ TT,(TT)
10$ CAIL B,400000 ;IF ARG IS IN HIGH SEGMENT,
10$ JRST ERRO2G ; MUST BE SUBR
CAML B,@VBPORG
JRST ERRO2B ;IF ARG > BPORG, THEN CANT BE A SUBR [MUST BE ARRAY]
ERRO2G: CAMLE TT,AR2A
CAMLE TT,B
JRST ERRO2B
MOVE AR2A,TT
HLRZ A,(D)
ERRO2B: HRRZ D,(D)
JUMPN D,ERRO2A
JRST GCP8A
ERRO2R: HRRZ AR1,VOBARRAY
MOVEI TT,(F)
SUB TT,TTSAR(AR1)
UNLOCKI ;GIVE A POOR INTERRUPT
LOCKI ; A CHANCE IN LIFE
ADD TT,TTSAR(AR1)
HRRI F,(TT)
JRST ERRO2A
SUBTTL ERROR, ERRFRAME, ERRPRINT
BEGFUN==.
$ERROR: JUMPE T,EROR1A ;(ERROR) SIMPLY ACTS LIKE (ERR)
AOJE T,[LERR 1,@(P)] ;(ERROR MSG)
AOJE T,ERRERC
AOJN T,ERERER
POP P,A
ERRERB: MOVEI B,(A)
CAIL A,QUDF
CAIL A,QUDF+NERINT
JRST ERRERN
10$ MOVEI D,(A)
10$ SUBI D,QUDF
.ELSE HRREI D,-QUDF(A)
JRST ERRERD
ERRERN: PUSHJ P,FIXP
JUMPE A,ERRERO
MOVEI D,-5(TT)
JUMPL D,ERRERO
ERRERD: CAIL D,NERINT ;# USER INTERRUPT ERRORS - RANGE FROM 0 TO NERINT-1
JRST ERRERO
MOVEI A,POP1J ;(ERROR MSG ARGS CHNO)
EXCH A,(P)
IORI D,<(SERINT)>←-5
DPB D,[2715←30 -1(P)]
XCT -1(P) ;THIS WINS FOR FAIL-ACT, FOR IT WILL
POPJ P, ; POPJ BY ISELF WITHOUT COMING HERE;
; DITTO FOR IO-LOSSAGE.
SUBR: HRRZ B,(A) ;SUBR 1
JRST ERRDCD
;;; ERRFRAME TAKES PDL POINTER, AND RETURNS AN ERROR FRAME.
;;; FORM OF RETURNED VALUE:
;;; (ERR <REGPDL PTR> <ERROR MSG> <SPECPDL PTR>)
;;; WHERE <ERROR MSG> TAKES ONE OF THREE FORMS:
;;; (<MESSAGE>)
;;; (<MESSAGE> <LOSING S-EXP>)
;;; (<MESSAGE> <LOSING S-EXP> <TYPE>)
;;; I.E. IT IS A LIST OF ARGS SUITABLE FOR THE ERROR FUNCTION.
ERRFRAME: JSP R,GTPDLP ;SUBR 1
$ERRFRAME ;MUST APPEAR TWICE
$ERRFRAME
JRST FALSE
SUB D,R70+1
PUSH FXP,D
PUSHJ FXP,SAV5M1
MOVE D,2(D) ;D SHOULD POINT TO JUST BELOW THE FRAME MARKER
PUSH P,R70
LSHC D,-33
LSH R,-40
CAIGE D,ERINT←-33
JRST EPR6
MOVEI A,QUDF(R)
PUSHJ P,ACONS
MOVEM A,(P)
HRRZ A,(FXP)
HRRZ A,2(A)
EPR6: CAIN D,LERR←-33
JRST EPR7
HRRZ A,(FXP)
HRRZ A,3(A)
HRRZ B,(P)
PUSHJ P,CONS
MOVEM A,(P)
HRRZ A,(FXP)
HRRZ A,2(A)
CAIN D,ERINT←-33
JRST EPR7
CAIE D,SERINT←-33
SKIPE R
JRST EPR5
EPR7: HRLI A,440600 ;IF MSG IS SIXBIT, MUST CREATE
MOVEM A,CORBP ; AN ATOMIC SYMBOL WHOSE PRINT NAME
MOVEI T,EPR1 ; IS THE MESSAGE
PUSHJ FXP,MKNR6C
PUSHJ P,RINTERN
EPR5: POP P,B
PUSHJ P,CONS
PUSH P,CR5M1PJ
PUSH P,A
POP FXP,D
JRST FRM4
EPR1: ILDB A,CORBP
CAIN A,'! ;! IS END OF MESSAGE
JRST FALSE
CAIN A,'↑ ;↑ CONTROLIFIES NEXT CHARACTER
JRST EPR3
CAIN A,'# ;# QUOTES NEXT CHAR
ILDB A,CORBP
EPR4: ADDI A,40
POPJ P,
EPR3: ILDB A,CORBP ;THIS "CONTROLIFICATION" ALGORITHM
ADDI A,40 ; CONVERTS ↑M TO CTRL/M, BUT ALSO ↑4 TO
TRC A,100 ; LOWER CASE T, ETC.; HENCE CAN REPRESENT
POPJ P, ; ALL OF ASCII USING ↑ AS AN ESCAPE
IFE QIO,[
ERRPRINT: ;SUBR 1
JSP R,GTPDLP ;PRINT OUT ERROR MESSAGE STACKED ON
$ERRFRAME ;PDL JUST PRIOR TO POINT SPECIFIED BY ARG
$ERRFRAME ;EXTRA COPY OF $ERRFRAME
JRST FALSE
HLRZ TT,1(D)
JUMPE TT,ERRPT4
PUSH P,1(D)
MOVE A,2(D)
PUSH P,A
JSR ERROR3
ERRPT3: MOVEI A,TRUTH
JRST POP2J
ERRPT4: MOVE T,D
JSR ERROR4
JRST TRUE
] ;END OF IFE QIO
IFN QIO,[
ERRPRINT: ;LSUBR (1 . 2)
JSP F,PRNARG
QERRPRINT
PUSHJ P,OFCAN
JSP R,GTPDLP ;PRINT OUT ERROR MESSAGE STACKED ON
$ERRFRAME ; PDL JUST PRIOR TO POINT SPECIFIED BY ARG
$ERRFRAME ;EXTRA COPY OF $ERRFRAME
JRST FALSE
MOVEI T,(D)
PUSH P,CTRUE
HLRZ TT,1(T)
JUMPN TT,ERROR3
JRST ERROR4
;OUTPUT FILE CANONICALIZER. MAKES CONTENTS OF AR1
; INTO A PURE LIST SUITABLE FOR FEEDING TO STRT.
OFCAN: PUSH P,A
MOVEI A,(AR1)
SKIPGE AR1
PUSHJ P,ACONS
HRRZ B,V%TYO
TLNN AR1,200000
PUSHJ P,XCONS
MOVEI AR1,(A)
JRST POPAJ
] ;END OF IFN QIO
;;@ END OF ERROR 43
;;; ERROR FILE HAS DEFINITION FOR BEGFUN
PGTOP ERR,[ERROR HANDLERS AND MESSAGES]
PGBOT TOP
LISPGO: SETOM AFILRD ;START HERE ON ≠G'ING
10% .SUSET [.S40ADDR,,[TWENTY,,FORTY]] ;SET .40ADDR
10% .SUSET [.RSNAM,,IUSN] ;GET INITIAL SNAME
10$ SETOM UPCOK ;TELL LISP ITS OK TOO
JRST 2,@LISPSW ;ZEROS OUT PROCESSOR FLAGS, AND TRANSFERS TO LISP
LSPRET: MOVE P,C2 ;RETURN TO TOP LEVEL BY ERR, THROW, AND LISP ERRORS
10$ PUSHJ P,SIXJBN
PUSHJ P,ERRPOP
LSPRT1: JSP T,TLVRSS ;RETURN TO TOP BY ↑G
JSP A,ERINIT
10% Q% .SUSET [.SMASK,,INTMSK]
Q$ INTON
Q$ SETZ A, ;NEED ZERO A FOR CHECKU IN NEWIO
PUSHJ P,CHECKU ;CHECK FOR DELAYED "REAL TIME" INTS
MOVEI A,QOEVAL
SKIPE B,VIQUOTIENT ;SHADES OF ERRLIST!!!
CALLF 2,QMAPC
HACENT: PUSH P,FLP .SEE PDLCHK
PUSH P,FXP
PUSH P,SP
PUSH P,LISP1 ;ENTRY FROM LIHAC
PUSH P,[Q.]
Q% SKIPN LINMODE
Q$ JSP F,LINMDP
PUSHJ P,ITERPRI
JRST LISP2 ;KLUDGE SO AS NOT TO MUNG *
SUBTTL BASIC TOP LEVEL LOOP
LISP1: PUSH P,LISP1 ;******* BASIC TOP LEVEL *******
HRRZM A,V. ;THE SYMBOL * GETS AS ITS VALUE THE
PUSH P,A
LISP2: JSP T,TLVRSS ; RESULT OF THE LAST TOP-LEVEL EVAL
POP P,B
SKIPN A,TLF
JRST LISP2A
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
JRST EVAL
LISP2A: MOVEI A,(B)
PUSHJ P,TLPRINT
Q% PUSHJ P,TERPRI
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
Q% PUSHJ P,IREAD ;READ-EVAL-PRINT LOOP OF DEFAULT TOPLEVEL
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY>
JRST LISP1F
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(A)
JRST LISP1F
CAMN AR1,V%TYO
JRST LISP1J
MOVEI TT,F.MODE
MOVE F,@TTSAR(A)
TLNE F,FBT<LN>
JRST LISP1F
LISP1D: TLOA AR1,-1
LISP1J: SKIPA AR1,VOUTFILES
SKIPN TTYOFF
LISP1E: PUSHJ P,TERP1
LISP1F: HRRZ AR1,VINFILE
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
PUSH P,AR1
REPEAT 2, PUSH P,[LISP1G] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
LISP1G: POP P,B
CAIE A,LISP1G
JRST LISP1Q
MOVE TT,TTSAR(B) ;SIMPLY TERPRI ON EOF
HRRI TT,FT.CNS ; IF APPROPRIATE
MOVEI AR1,NIL
TLNN TT,TTS<TY>
JRST LISP1E
SKIPN AR1,@TTSAR(B)
JRST LISP1F
CAMN AR1,V%TYO
JRST LISP1J
JRST LISP1D
LISP1Q:
] ;END OF IFN QIO
PUSHJ P,SPCFLS ;MAYBE NEED TO FLUSH A SPACE AFTER READ
;THE BREAK LOOP USES THIS AS A SUBROUTINE
LISP1A: MOVEM A,VIDIFFERENCE ;THE SYMBOL - GETS THE TYPED-IN
MOVEI B,(A) ; EXPRESSION AS ITS VALUE AND KEEPS IT
EXCH B,VIPLUS ;THE SYMBOL + GETS THE THE TYPED-IN
JSP T,SPECBIND ; EXPRESSION AS ITS VALUE, BUT NOT
0 B,VIPLUS ; UNTIL AFTER IT HAS BEEN EVALUATED.
CEVAL: PUSHJ P,EVAL ;SPECBINDING IT ENSURES THAT IT WILL
JUMPE UNBIND ; GET THIS VALUE IN SPITE OF ERRORS.
NILBAD: PUSH P,A ;FOO! WELL, ERROR HANDLING SAVES
PUSH P,CPOPAJ ;ALL ACS IN CASE YOU WANT TO CONTINUE
MOVS A,NIL
SETZM NIL
PUSHJ P,ACONS
%FAC [SIXBIT \NIL CLOBBERED!\]
;;; PUSHJ HERE WITH PROPER VALUES FOR THE RIGHT HALVES
;;; OF <FLP, FXP, SP> IN <TT, D, R>. WILL ERROR OUT
;;; IF THEY DON'T MATCH UP. USED FOR TRAPPING GROSS
;;; ERRORS IN THE SYSTEM.
PDLCHK: SETZ T,
CAIE TT,(FLP)
MOVEI T,QFLPDL
CAIE D,(FXP)
MOVEI T,QFXPDL
CAIE R,(SP)
MOVEI T,QSPECPDL
JUMPE T,CPOPJ ;EVERYBODY HAPPY?
PDLCRP: MOVEI A,(T) ;NO, PDL CRAP-OUT
LER3 [SIXBIT \OUT OF PHASE (SYSTEM ERROR)!\]
IFN QIO,[
;;; SKIP IF INPUT FILE IN LINE MODE.
;;; ALSO LEAVE OUTFILES IN AR1 AND READTABLE IN AR2A.
;;; FURTHERMORE LEAVE INPUT FILE IN C (SEE TLPRINT).
;;; ALSO LEAVE TTSAR OF INPUT FILE IN T.
LINMDP: JSP T,GTRDTB
HRRZ C,VINFILE
SKIPE TAPRED
CAIN C,TRUTH
HRRZ C,V%TYI
MOVEI TT,F.MODE
MOVE T,@TTSAR(C)
SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
TLNN T,FBT<LN>
JRST (F) ;TYPICALLY RETURN TO AN ITERPRI
JRST 1(F) ; OR SKIP OVER IT
] ;END OF IFN QIO
TLPRINT: PUSH P,A ;TOP-LEVEL PRINT
Q% SKIPN LINMOD
Q% PUSHJ P,ITERPRI
IFN QIO,[
JSP F,LINMDP ;LEAVES INPUT FILE IN C
JRST TLPR1
MOVEI TT,FT.CNS
HRRZ C,@TTSAR(C)
TLNE T,TTS<TY>
CAME C,V%TYO
TLPR1: PUSHJ P,ITERPRI
] ;END OF IFN QIO
MOVE A,(P)
PUSHJ P,IPRIN1
MOVEI A,40
PUSHJ P,TYO
JRST POPAJ
IPRIN1:
Q% SKIPN VPRIN1
Q$ SKIPN V%PR1
JRST PRIN1
Q% JCALLF 1,@VPRIN1
Q$ JCALLF 1,@V%PR1
;;; TOP LEVEL VARIABLE SETTINGS
TLVRSS: MOVE A,[PNBUF,,PNBUF+1]
SETZM PNBUF
BLT A,PNBUF+LPNBUF-1
TLVRS1: PUSH P,EOFRTN
Q% MOVE A,[INTSV,,INTSV+1]
Q% SETZM INTSV
Q$ MOVE A,[INTPDL+1,,INTPDL+2]
Q$ SETZM INTPDL+1
BLT A,ERRTN+LEP1-1
POP P,EOFRTN
SETZB NIL,PANICP
SETZB A,PSYMF
SETZB B,EXPL5
SETZB C,PA3
Q% SETZB AR1,MKNM3
Q$ SETZB AR1,RDLARG
SETZB AR2A,QF1SB
SETZM ARGLOC
SETZM ARGNUM
SETOM ERRSW
Q% SETOM RRDF
Q$ SETZM BFPRDP
JRST (T)
IFN D10,[
SIXJBN: PJOB B,
IDIVI B,10.
MOVSI D,20(C)
IDIVI B,10.
MOVSI A,202000
LSH B,12.+18.
LSH C,6.+18.
ADD A,B
ADD A,C
ADD A,D
HRRI A,(SIXBIT /LSP/)
MOVEM A,D10NAM ;SAVE ###LSP AS TEMP FILE NAME
POPJ P,
] ;END OF IFN D10
SUBTTL INITIALIZATION ON ↑G QUIT AND ERRORS
;;; ERINIT RESETS PDL POINTERS, THEN FALLS INTO ERINI0.
;;; ERINI0 RESETS VARIOUS VARIABLES AND PERFORMS CLEANUP.
ERINIT:
IFE ITS,[
MOVE P,C2 ;SET UP PDL POINTERS
MOVE FXP,FXC2
MOVE FLP,FLC2
MOVE SP,SC2
] ;END OF IFE ITS
.ELSE,[
PIOF
MOVE T,PDLFL1 ;CONTAINS <- # OF PDL PAGES,,# OF 1ST PDL PAGE>
.CALL PDLFLS ;FLUSH ALL PDL PAGES
.VALUE
MOVE T,[$NXM,,QRANDOM]
MOVE TT,PDLFL2 ;CONTAINS <- # OF PDL SEGS,,# OF 1ST PDL SEG>
MOVEM T,ST(TT) ;UPDATE SEGMENT TABLE TO REFLECT
AOBJN TT,.-1 ; LOSS OF PDL PAGES
HRRZ T,PDLFL1
ROT T,-4
ADDI T,(T)
ROT T,-1
TLC T,770000
ADD T,[450200,,PURTBL]
SETZ D,
HLRE TT,PDLFL1
ERINI8: TLNN T,730000
TLZ T,770000
IDPB D,T
AOJL TT,ERINI8
MOVEI AR2A,(A)
IRP Z,,[P,FLP,FXP,SP]
Q% MOVEI A,Z
Q$ MOVEI F,Z
MOVE Z,C2-P+Z ;CAUSE ONE PDL PAGE
MOVEI D,1(Z) ; FOR Z TO EXIST
ANDI D,PAGMSK
JSR PDLSTH .SEE PDLST0
TERMIN
MOVEI A,(AR2A)
ERIN8G: MOVE T,[XPDL,,ZPDL]
BLT T,ZSPDL
] ;END OF .ELSE
ERINI0: SETZB NIL,TAPRED ;INITIALIZATION AFTER PDL SETUP
SETZM NOQUIT
SETZM FASLP
IFN USELESS, SETZM TYOSW
SETZM INTFLG
SETZM INTAR
SETZM VEVALHOOK
Q% SETZM TYIMAN
Q% SETZM TMBBC
Q% SETZM RDTYBF
IFN QIO,[
SETZM GCFXP ;NON-ZERO WOULD MEAN INSIDE GC
SETZM BFPRDP
MOVE T,[-LINTPDL,,INTPDL]
MOVEM T,INTPDL
;; MOVEI T,READP
;; MOVEM T,READPMAN
;; MOVEI T,UNRD
;; MOVEM T,UNREADMAN
IRP X,,[TYIMAN,UNTYIMAN]Y,,[$DEVICE,UNTYI]
MOVEI T,Y
MOVEM T,X
TERMIN
] ;END OF IFN QIO
;FALLS THROUGH
;FALLS IN
ERINI2: SKIPL MUNGP ;MAYBE NEED TO UNMUNG SYMBOLS AND SARS
JRST ERINI6
MOVE D,SYSGLK
ERINI5: JUMPE D,ERIN5A
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ
LDB D,[SEGBYT,,GCST(D)]
ERIN5C: MOVSI R,1
ANDCAB R,(F) ;UNMUNGS THE SYMBOL HEADER, IF NECESSARY
HLRZS R
HRRZ R,(R) ;GET ADDR OF VALUE CELL
CAIL R,BVCSG
CAIL R,BVCSG+<NXVCSG+1>*SEGSIZ
JRST .+2
JRST ERIN5D
CAIL R,BPURFS
CAIL R,PFSLAST
JRST .+2
JRST ERIN5D
HRRZS (R) ;UNMUNGS THE VALUE CELL, IF STORED IN LIST SPACE
ERIN5D: AOBJN F,ERIN5C
JRST ERINI5
ERIN5A: MOVE F,[SARTOB,,B]
BLT F,LPROGZ
MOVE D,SASGLK
ERIN5B: JUMPE D,ERINI6
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ/2
LDB D,[SEGBYT,,GCST(D)]
JRST SATOB1
ERINI6: HRRZS MUNGP
SKIPN MUNGP ;UNMUNG VALUE CELLS (SEE ALIST)
JRST ERIN6A
MOVEI F,BVCSG
SUB F,EFVCS
HRLI F,(F)
HRRI F,BVCSG
HRRZS (F)
AOBJN F,.-1
SETZM MUNGP
ERIN6A: MOVE B,[ERRTN,,ERRTN+1]
SETZM ERRTN
BLT B,UIRTN
Q% SETOM RRDF
SETOM ERRSW
MOVSI B,-NSFC
ERINI3: MOVE C,SFXTBI(B) ;RESTORE CLOBBERED LOCATIONS
MOVEM C,@SFXTBL(B)
AOBJN B,ERINI3
Q% SETZM WAITFL ;IS EVERYBODY HAPPY?
TLZ A,-1
PION
10X WARN [PION IN ERINIT?]
JRST (A)
SARTOB: ;TURN OFF MARK BITS IN SARS
OFFSET B-.
SATOB1: ANDCAM SATOB7,TTSAR(F)
AOBJP F,ERIN5B
AOJA F,SATOB1
SATOB7:
TTS<GC>,,
LPROGZ==.-1
OFFSET 0
.HKILL SATOB1 SATOB7
PDLFLS: SETZ
SIXBIT \CORBLK\
1000,,0 ;DELETE PAGES...
1000,,-1 ; FROM MYSELF...
SETZ T ; AND HERE'S HOW MANY AND WHERE!
SUBTTL SPECIAL VARIABLE BINDING AND UNBINDING ROUTINES
JFCL ;HISTORICAL LOSS -- EVENTUALLY FLUSH
SPECBIND: MOVEM SP,SPSV ;0 0,FOO MEANS FOO IS ADDR OF SVC TO BE BOUND TO NIL
SPEC1: LDB R,[271500,,(T)] ;0 N,FOO MEANS SVC FOO TO BE BOUND TO CONTENTS OF ACC N
JUMPE R,SPEC4
CAILE R,17 ;7←41 M,FOO MEANS BIND FOO TO -M(P)
JRST SPEC3 ;OTHERWISE, IS PDP10 INSTRUCTION, SO EXIT
SPEC2: HRRZ R,(R) ;NOTE WELL! NCOMPLR DEPENDS ON THE FACT
CAML R,NPDLL ; THAT R = TT+2 = NUMVALAC+2
CAMLE R,NPDLH
JRST SPEC4
PUSH FXP,T
MOVEI T,(R)
LSH T,-SEGLOG
SKIPL T,ST(T) ;NMK1 WILL WANT TYPE BITS IN T
TLNN T,$FXP+$FLP
JRST SPEC5
HRR T,(FXP)
LDB R,[271500,,(T)] ;RECOMPUTE ADDRESS OF FROB
CAIG R,17
JRST SPEC6
TRC R,16000#-1
ADDI R,1(P)
SPEC6: PUSHJ P,ABIND3 ;TEMPORARILY CLOSE THE BIND BLOCK
PUSH P,A
HRRZ A,(R)
PUSHJ P,NMK1
MOVEM A,(R) ;CLOBBER LOC OF FROB WITH NEW NUMBER
CAIN R,A ;GRUMBLE
MOVEM A,(P)
SUB SP,R70+1 ;SO RE-OPEN THE BIND-BLOCK
MOVEI R,(A) ;THEREBY INHIBITING INTERRUPTS
POP P,A
SPEC5: POP FXP,T
SPEC4: EXCH R,@(T)
HRL R,(T)
PUSH SP,R
AOJA T,SPEC1
SPEC3: CAIGE R,16000
JRST SPECX
TRC R,16000#-1 ;RH OF R NOW HAS N
ADDI R,1(P) ;SPECBINDING OFF PDL
JRST SPEC2
ERRPOP: SKIPA TT,ZSC2 ;TOTALLY POP OFF SPECPDL FOR ERRORS
UBD0: TLZA TT,-1 ;POP SPECPDL TO PLACE SPECIFIED IN TT
SETOM (TT) ;ERRPOP MUST SETOM - SEE UBD4
UBD: CAIL TT,(SP) ;RESTORE THE SPDL BY RESTORING VALUES
JRST UNBND2 ;UNTIL (SP) MATCHES (TT)
POP SP,R
HLRZ D,R
TLZ R,-1
CAMGE R,ZSC2
JRST UBD3
CAIG R,(SP)
IFE FUNAFL, JRST UBD
IFN FUNAFL,[
JRST UBD4
JUMPN D,UBD3
.VALUE ;SOMEBODY SCREWED THE SPECPDL - HELP!!!
] ;END OF IFN FUNAFL
UBD3: HRRZM R,(D)
UBD1: JRST UBD
IFN FUNAFL,[
UBD4: HLRZ D,(SP)
JUMPN D,UBD ;AMONG OTHER THINGS, ERRPOP'S SETOM MAKES THIS JUMP
PUSH FXP,T ;MUST SAVE T
MOVEI T,(R)
PUSHJ P,AUNBN0 ;FOUND A FUNARG BINDING BLOCK
POP FXP,T ; - USE SPECIAL ROUTINE TO UNBIND IT
JRST UBD
] ;END OF IFN FUNAFL
UNBIND: POP SP,T
MOVEM TT,UNBND3 ;HORRIBLE HACK TO SAVE AC TT. THINK ABOUT THIS SOME DAY
UNBND0: TLZ T,-1 ;AUNBIND ENTERS HERE
UNBND1: CAIN T,(SP)
JRST UNBND2
POP SP,TT
MOVSS TT
HLRZM TT,(TT)
JRST UNBND1
;;; BIND, AND MAKE-VALUE-CELL ROUTINES.
;;; PUSHJ P,BIND WITH SYMBOL IN A, VALUE IN AR1.
;;; USES ONLY A, TT; MUST SAVE T
;;; JSP TT,MAKVC WITH AN ATOMIC SYMBOL ON THE PDL (WHICH IS POPPED)
;;; AND THE VALUE IN B. RETURNS ADDRESS OF NEW VALUE CELL IN A.
;;; (LATTER CROCK FOR BIND1 ONLY). USES ONLY A,B,TT.
BIND: SKIPN TT,A
JRST BIND5
HLRZ A,(A)
XCTPRO
HRRZ A,(A)
NOPRO
CAIN A,SUNBOUND
JRST BIND1
BIND4: PUSH SP,(A)
HRLM A,(SP)
STQPUR: HRRZM AR1,(A)
POPJ P,
BIND5: MOVEI A,VNIL ;ALLOW PURPGI TRAP TO WORK JUST
CBIND4: JRST BIND4 ;LIKE FOR SETQING T
BIND1: PUSH P,CBIND4 ;SET UP FOR CALL TO MAKVC
PUSH P,B
PUSH P,TT
MOVEI B,QUNBOUND
JSP TT,MAKVC
POPBJ: POP P,B
CPOPBJ: POPJ P,POPBJ
MAKVC: PUSH FXP,TT ;SAVE RETURN ADDR
SPECPRO INTZAX
MAKVC0: SKIPN A,FFVC
JRST MAKVC3
EXCH B,@FFVC
XCTPRO
HRRZM B,FFVC
NOPRO
MAKVC1: HLRZ B,@(P) ;POINTER TO SYMBOL HEADER IS ON STACK
PURTRAP MAKVC9,B, HRRM A,(B)
MAKVCX: SUB P,R70+1 ;POP POINTER, RETURN ADDRESS OF VALUE CELL
POPJ FXP,
IFE ITS,[
MAKVC3: PUSHJ P,CONS1
JRST MAKVC1
] ;END OF IFE ITS
SUBTTL VARIOUS ODDBALL CONSERS
IFN BIGNUM,[
C1CONS: EXCH T,YAGDBT
JSP T,FWCONS
EXCH T,YAGDBT ;FALL INTO ACONS
] ;END OF IFN BIGNUM
BAKPRO
ACONS: SKIPN FFS ;THIS IS A CONS LIKE XCONS
PUSHJ P,AGC ;BUT USES ONLY ACCUMULATOR A
MOVSS A ;SWAP HALVES OF A, THEN
SPECPRO INTACX
EXCH A,@FFS ;CONS WHOLE WORD FROM A
XCTPRO
EXCH A,FFS
NOPRO
POPJ P,
IFN BIGNUM,[
BAKPRO
BGNMAK: ;MAKE A POSITIVE BIGNUM (SAME AS BNCONS)
BNCONS: SKIPN FFB ;BIGNUM CONSER
PUSHJ P,AGC
EXCH A,@FFB
XCTPRO
EXCH A,FFB
NOPRO
POPJ P,
] ;END OF IFN BIGNUM
SIXMAK: MOVSI TT,(SIXBIT \@\) ;"CONSS" UP SIXBIT FROM ASCII
MOVEM TT,SIXMK2
MOVE AR1,[440600,,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA
MOVE TT,SIXMK2
POPJ P,
SIXMK1: CAIGE A,140 ;THIS SAYS CONVERT LOWER CASE TO UPPER
TRC A,40 ;CONVERT CHAR TO SIXBIT
TLNE AR1,770000
.UDT4: IDPB A,AR1 ;MAYBE SAVE IT, UNLESS ALREADY HAVE SIX
POPJ P,
SUBTTL CATCH, THROW, ERRSET, .SET, AND BREAK ROUTINES
CATPUS: PUSH P,B
CATPS1: MOVEM A,CATID
JSP T,ERSTP
MOVEM P,CATRTN
JRST (TT)
THROW5: SKIPE D,UIRTN ;IF NO USER INTERRUPT FRAME STACKED,
CAIG D,(TT) ; OR IF IT IS BELOW THE CATCH FRAME,
JRST THROW3 ; THEN JUST EXIT THE CATCH FRAME
JSP TT,UIBRK ;OTHERWISE BREAK OUT OF THE INTERRUPT
THROW1: SKIPN TT,CATRTN ;SKIP IF CATCH FRAME BELOW US
JRST THROW4
JUMPE B,THROW5
THROW6: SKIPE T,(TT) ;(CATCH FOO NIL) = (CATCH FOO)
CAIN B,(T)
JRST THROW5 ;CATCH ID MATCHES THROW ID
MOVE TT,<-LEP1+1>+<CATRTN-ERRTN>(TT) ;GO BACK ONE CATCH
JUMPN TT,THROW6 ;FALL THROUGH IF NO MORE
THROW7: EXCH A,B
%UGT EMS29
EXCH A,B
JRST THROW1
THROW4: JUMPN B,THROW7 ;NO CATCH FRAME -- GIVE UGT EROR
JRST LSPRET ;IF NO THROW TAG, THROW TO TOP LEVEL
JRST THROW1 ;COMPILED THROWS COME HERE
ERUNDO: SKIPN ERRTN ;COMPILED ERR, AND NORMAL ERRSET EXIT COMES HERE
JRST LSPRET ;RETURN TO TOPLEVEL
ERR0:
IFN USELESS, SETZM TYOSW
JUMPN A,ERUN0 ;ELSE, BREAK UP AN ERRSET
SKIPE V.RSET
SKIPN VERRSET ;ERRSET BEING BROKEN BY AN ERROR
JRST ERUN0
PUSH P,A
Q% MOVEI A,ERSTBK
Q$ MOVEI D,1001 ;ERRSET USER INTERRUPT
PUSHJ P,UINT
POP P,A
JRST ERUN0
SKIPA TT,CATRTN ;PHOOEY, COMPILED CODE COMES HERE WHEN A
GOBRK: MOVE TT,ERRTN ;GO OR RETURN OCCURS WITHIN AN ERRSET OR CATCH
JUMPE TT,ER4
EXCH T,-LERSTP(TT)
THROW3: MOVE P,TT
JRST ERR1
IOGBND: JSP T,SPECBIND ;BIND ALL I/O CONTROL VARIABLES TO NIL:
TTYOFF ; ↑W
TAPRED ; ↑Q
TAPWRT ; ↑R
Q% LPTON ; ↑B
IFN MOBIOF, DISPON ; ↑F
EPOPJ: POPJ P,
;;; MOVEI D,LOOP ;ROUTINE TO LOOP
;;; PUSHJ P,BRGEN
;;; GENERATES A BREAK LOOP SURROUNDED BY A CATCH AND AN
;;; ERRSET. ERRORS CAUSE THE LOOP TO BE RE-ENTERED.
;;; BRGEN RETURNS WHEN THE LOOP ROUTINE PERFORMS A
;;; THROW TO THE TAG BREAK.
BRGEN: MOVEI A,QBREAK ;CATCH ID = BREAK
JSP TT,CATPS1 ;SET UP CATCH FRAME
PUSH P,D
PUSH P,. ;RETURN POINT FOR ERROR
JSP T,ERSTP ;SET UP ERRSET FRAME
SETOM ERRSW
MOVEM P,ERRTN
JRST @-LERSTP-1(P) ;CALL RANDOM ROUTINE
;;; BREAK LOOP USED BY *BREAK
BRLP1: PUSH P,FLP
PUSH P,FXP
PUSH P,SP
PUSHJ P,LISP1A
MOVEM A,V.
PUSHJ P,TLPRINT
HRRZ TT,-2(P)
HRRZ D,-1(P)
HRRZ R,(P)
SUB P,R70+3
PUSHJ P,PDLCHK ;CHECK PDL LEVELS
Q% JRST TERPRI ;WILL RETURN TO BRLP
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY>
POPJ P,
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(A)
POPJ P,
CAMN AR1,V%TYO
JRST BRLP5A
MOVEI TT,F.MODE
MOVE F,@TTSAR(A)
TLNE F,FBT<LN>
POPJ P,
JRST BRLP5A
] ;END OF IFN QIO
BRLP: PUSH P,BRLP
SKIPE A,BLF
JRST EVAL ;EVAL BREAKLEVEL FORM (RETURNS TO BRLP)
Q% PUSHJ P,IREAD
IFN QIO,[
HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
PUSH P,A
REPEAT 2, PUSH P,[BRLP5] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
BRLP5: POP P,B
CAIE A,BRLP5
JRST BRLP6
MOVE TT,TTSAR(B) ;SIMPLY TERPRI ON EOF
TLNN TT,TTS<TY> ; IF APPROPRIATE
POPJ P,
MOVEI TT,FT.CNS
SKIPN AR1,@TTSAR(B)
POPJ P,
BRLP5A: TLO AR1,-1
SKIPN TTYOFF
JRST TERP1
POPJ P,
BRLP6:
] ;END OF IFN QIO
PUSHJ P,SPCFLS
SKIPN VDOLLRP
JRST BRLP4
CAMN A,VDOLLRP
JRST BRLP7
BRLP4: HLRZ B,(A)
CAIE B,QRETURN
JRST BRLP1
JSP T,%CADR
BRLP3: PUSHJ P,EVAL
BRLP2: MOVEI B,QBREAK
JRST THROW1 ;ESCAPE FROM BRGEN LOOP
BRLP7: MOVEI A,NIL
JRST BRLP2
SPCFLS: SKIPE VOREAD
POPJ P,
PUSH P,A
PUSHJ P,ATOM
JUMPE A,POPAJ
MOVEI T,0 ;PEEL OFF A SPACE, IF THAT
PUSHJ P,TYIPEEK+1 ;WAS WHAT TERMINATED THE ATOM
MOVE T,VREADTABLE
MOVE TT,@TTSAR(T)
MOVEI T,0
TLNE TT,100000 ;WORTHLESS CHAR, OR SPACE ETC.
PUSHJ P,%TYI
JRST POPAJ
.SET: EXCH A,AR1
.SET1: PUSH P,A
PUSHJ P,BIND
POP P,A
EXCH A,AR1
JRST SETXIT
.STOLZ: PUSH P,B
PUSHJ P,NCONS
MOVEI B,QM
PUSHJ P,XCONS
MOVEI B,QSTORE
PUSHJ P,XCONS
JRST .STOL1
.STORE: SKIPN D,LISAR
JRST .STOLZ
HLL D,ASAR(D)
TLNE D,AS<FX+FL>
JRST .STOR2
.STOR0: MOVEI TT,(R)
JUMPL R,.STOR1
HRLM A,@TTSAR(D)
JRST (T)
.STOR1: HRRM A,@TTSAR(D)
JRST (T)
.STOR2: MOVEI F,(T)
TLNN D,AS<FX>
JSP T,FLNV1X
JSP T,FXNV1
.STOR3: EXCH TT,R
MOVEM R,@TTSAR(D)
JRST (F)
FWNACK: SETZ T, ;COUNT UP ACTUAL NUMBER OF ARGS
MOVEI D,(A) ;LEAVES RESULT IN T
FWNAC1: JUMPE D,LWNACK
HRRZ D,(D)
SOJA T,FWNAC1
LWNACK: MOVE D,(TT) ;GET WORD OF BITS
ASH D,(T)
TLNE D,2 ;SKIP UNLESS WNA
JRST 1(TT)
JRST WNAL0
;;; PUSH CRUFT FOR AN ERRSET/CATCH/READEOF FRAME
;;; BEWARE! THE COMPILER DEPENDS ON THE LENGTH OF THE
;;; ERRSET FRAME BEING A CONSTANT.
ERSTP: PUSH P,PA3 ;"ERRSET" PUSH
PUSH P,SP ;MUST SAVE TT - SEE $TYI
PUSH P,FLP
PUSH P,FXP
REPEAT LEP1, PUSH P,ERRTN+.RPCNT
LERSTP==.-ERSTP ;LENGTH OF ERRSET PUSH
JRST (T)
ERUN0: HRRZ TT,ERRTN ;GENERAL BREAK OUT OF AN ERRSET
SKIPE D,UIRTN
CAIL TT,(D)
JRST ERR1A
JSP TT,UIBRK ;MAYBE BREAK UP A USER INTERRUPT FIRST
JRST ERUN0
ERR1A: MOVE P,ERRTN
ERR1: SETZM PANICP
MOVSI D,-LEP1+1(P)
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,EPC1
POP P,FXP
POP P,FLP
POP P,TT
POP P,PA3
JRST UBD0 ;RESTORE CONDITIONS AND PROCEED
EPC1: LEP1,,LEP1
UIBRK:
Q% HRRM TT,-2(D) ;BREAK OUT OF A USER INTERRUPT
Q$ HRRM TT,-1(D)
HRRO FXP,1(D) ;JUST SET LEFT HALF OF PDL POINTERS
HLRO FLP,1(D) ; TO -1 FOR BIBOP, AND LET PDLOV
Q% HRROI P,-LUINF-1(D) ; DO THE REST OF THE WORK!
Q$ HRROI P,-UIFRM(D)
IFE QIO,[ .SEE FRETURN
MOVEM F,-LSWS(FXP) ;LET F BE SECURE OVER THE RESTORATION
MOVEM T,-LSWS-4(FXP) ;T TOO
MOVEM C,-3(P) ;C TOO
MOVEM B,-4(P) ;B TOO
MOVEM A,LUINF(P) ;A TOO
] ;END OF IFE QIO
IFN QIO,[
MOVEM F,UISAVT-T+F(FXP) ;LET F BE SAFE OVER RESTORATION
MOVEM T,UISAVT(FXP) ;T TOO
MOVEM C,UISAVA-A+C(P) ;C TOO
MOVEM B,UISAVA-A+B(P) ;B TOO
MOVEM A,UISAVA(P) ;A TOO
] ;END OF IFN QIO
JRST UINT0X
CIN0: IN0 ;SURPRISE!
CONS1FX: TDZA B,B
CONSPFX: POP FXP,TT
CONSFX: JSP T,FXCONS
CONSIT: PUSHJ P,CONS
BAPOPJ: MOVEI B,(A)
POPJ P,
SUBTTL VARIOUS COMMON EXITS
ZPOPJ: TDZA TT,TT ;ZERO TT, THEN POPJ
POPNVJ: JSP T,FXNV1 ;FXNV1, THEN POPJ
CCPOPJ: POPJ P,CCPOPJ ;NOT CPOPJ! WILL SCREW BAKTRACE
0POPJ: SKIPA A,CIN0 ;PUT A LISP FIXNUM 0 IN A AND POPJ
POP2J: SUB P,R70+2 ;POP 2 PDL SLOTS AND POPJ
CPOPJ: POPJ P,CPOPJ ;SACRED TO BAKTRACE (Q.V.)
S1PAJ: SUB P,R70+1 ;POP 1 PDL SLOT, POP INTO A, AND POPJ
POPAJ: POP P,A ;POP A, THEN POPJ
CPOPAJ: POPJ P,POPAJ
POPJ1: AOSA (P) ;SKIPPING POPJ RETURN
POP1J: SUB P,R70+1 ;POP 1 PDL SLOT AND POPJ
CPOP1J: POPJ P,POP1J
M1TTPJ: SKIPA TT,XC-1 ;-1 IN TT, THEN POPJ
POPCJ: POP P,C ;POP C, THEN POPJ
CPOPCJ: POPJ P,POPCJ
UNLKFALSE: TDZA A,A
UNLKTRUE: MOVEI A,TRUTH
UNLKPOPJ
PX1J: SUB FXP,R70+1
POPJ P,
POPXDJ: POP FXP,D
POPJ P,
SUBTTL VARIOUS COMMON SAVE AND RESTORE ROUTINES
SAV5: PUSH P,A
SAV5M1: PUSH P,B
SAV5M2: PUSH P,C
SAV5M3: PUSH P,AR1
PUSH P,AR2A
CPOPXJ: POPJ FXP,
SAV3: PUSH P,A
PUSH P,B
PUSH P,C
POPJ FXP,
R5M1PJ: PUSH FXP,CCPOPJ
RST5M1: POP P,AR2A
POP P,AR1
POP P,C
POP P,B
CR5M1PJ: POPJ FXP,R5M1PJ
RST5M2: POP P,AR2A
POP P,AR1
POP P,C
POPJ FXP,
RST5M3: POP P,AR2A
POP P,AR1
POPJ FXP,
SAVX5: PUSH FXP,T
PUSHJ P,SAVX3
PUSH FXP,F
POPJ P,
SAVX3: PUSH FXP,TT
PUSH FXP,D
PUSH FXP,R
POPJ P,
RSTX5: POP FXP,F
POP FXP,R
POP FXP,D
PXTTTJ: POP FXP,TT
POPXTJ: POP FXP,T
POPJ P,
RSTX3: POP FXP,R
RSTX2: POP FXP,D
RSTX1: POP FXP,TT
CPOPNVJ: POPJ P,POPNVJ
SUBTTL VARIOUS KINDS OF FRAME MARKERS
$ERRFRAME=525252,,EPOPJ ;ERROR FRAME
$EVALFRAME=525252,,POP2J ;EVAL FRAME
;; $APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME DEFINED BELOW
$UIFRAME=525252,,CPOPAJ ;USER INTERRUPT FRAME
;;; FORMAT OF EVALFRAME:
;;; <FLP>,,<FXP>
;;; <SP>,,<FORM>
;;; $EVALFRAME
;;; FORMAT OF APPLYFRAME:
;;; -- ARGS --
;;; <FLP>,,<FXP>
;;; <SP>,,<FUNCTION>
;;; $APPLYFRAME
;;; WHERE -- ARGS -- MAY BE ONE OF THREE THINGS, DEPENDING
;;; ON ITS LEFT HALF:
;;; LH=0 RH=LIST OF ARGS
;;; LH<0 LH,,RH=AOBJN POINTER TO ARGS VECTOR (E.G. FOR LSUBR)
;;; LH>0 RH=LAST ARG; OTHER ARGS ARE BELOW THIS ON THE
;;; STACK. IN THIS CASE THE APPLYFRAME MAY BE MORE
;;; THAN FOUR WORDS LONG.
;;; EXAMPLE: MOVEI A,QFOO
;;; MOVEI B,QBAR
;;; CALL 2,QUUX
;;; CAUSES THIS APPLYFRAME TO APPEAR ON THE STACK:
;;; 0,,QFOO
;;; 2,,QBAR
;;; <FLP>,,<FXP>
;;; <SP>,,QUUX
;;; $APPLYFRAME
AFPOPJ: HLRE T,-2(P) ;APPLYFRAME POPJ
SKIPG T ;FIGURE OUT LENGTH OF
MOVEI T,1 ; APPLY FRAME
ADDI T,2
HRLI T,(T)
SUB P,T ;POP CRUFT FROM PDL
POPJ P, ;RETURN
$APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME
SUBTTL NUMERIC TYPE-TESTING, CONVERSION, AND VALUE ROUTINES
IFN BIGNUM,[
FLTSK1: %WTA NMV5 ;BIGNUM NOT ACCEPTABLE
JRST FLTSKP
] ;END OF IFN BIGNUM
FLTSK2: %WTA NMV3 ;NON-NUMERIC VALUE
FLTSKP: MOVEI TT,(A) ;"FLOAT SKIP" ROUTINE
LSH TT,-SEGLOG ; SKIPS 0 FOR FIXNUMS, 1 FOR FLONUMS
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
2DIF JRST @(TT),FLTSTB,QLIST .SEE STDISP
FLTSTB: FLTSK2 ;LIST ;ERROR
FLTSFX ;FIXNUM ;SKIPS 0
FLTSFL ;FLONUM ;SKIPS 1
BG$ FLTSK1 ;BIGNUM ;ERROR
FLTSK2 ;SYMBOL ;ERROR
REPEAT HNKLOG, FLTSK2 ;HUNKS ;ERROR
FLTSK2 ;RANDOM ;ERROR
FLTSK2 ;ARRAY ;ERROR
IFN .-FLTSTB-NTYPES, WARN [WRONG LENGTH TABLE]
IFN BIGNUM, NVSKBG:
FLTSFX: MOVE TT,(A)
JRST (T)
IFN BIGNUM, NVSKFX:
FLTSFL: MOVE TT,(A)
JRST 1(T)
IFN BIGNUM,[
NVSKP2: %WTA NMV3 ;NON-NUMERIC VALUE
NVSKIP: MOVEI TT,(A) ;"NUMERIC VALUE SKIP"
LSH TT,-SEGLOG ;SKIPS: 0 => BIGNUM, 1 => FIXNUM, 2 => FLONUM, ELSE ERROR
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
2DIF JRST @(TT),NVSKTB,QLIST .SEE STDISP
NVSKTB: NVSKP2 ;LIST ;ERROR
NVSKFX ;FIXNUM ;SKIPS 1
NVSKFL ;FLONUM ;SKIPS 2
BG$ NVSKBG ;BIGNUM ;SKIPS 0, LEAVES BIGNUM HEADER IN TT
NVSKP2 ;SYMBOL ;ERROR
REPEAT HNKLOG, NVSKP2 ;HUNKS ;ERROR
NVSKP2 ;RANDOM ;ERROR
NVSKP2 ;ARRAY ;ERROR
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]
NVSKFL: MOVE TT,(A)
JRST 2(T)
] ;END OF IFN BIGNUM
CFIX1: FIX1 ;FOR (% 0 0 FIX1)
CFLOAT1: FLOAT1 ;FOR (% 0 0 FLOAT1)
R70: REPEAT 20, .RPCNT,,.RPCNT ;COMMON LAP CONSTANTS ALSO USED BY LISP CODE
ZZZ==5
IFL ZZZ-NACS, ZZZ==NACS ;NEED AT LEAST <NACS> OF THESE
REPEAT ZZZ, .RPCNT-ZZZ
XC==. ;WRITE "XC-N" TO GET THE CONSTANT -N
FIX2: JSP T,IFIX
FIX1: JSP T,FIX1A
POPJ P,
IFIX: MULI TT,400
TSC TT,TT
ASH TT+1,-243(TT)
MOVE TT,TT+1
JRST (T)
FLOAT2: JSP T,IFLOAT
FLOAT1: JSP T,FPCONS
POPJ P,
IFLOAT: TLNE TT,777000
JRST IFLT1
IFLT5: FSC TT,233 ;FSC NORMALIZES RESULT
JRST (T)
IFLT1: TLC TT,777000
TLCN TT,777000
JRST IFLT5
IFLT2: MOVEM D,IFLT9 ;28. TO 35. BITS MAGNITUDE
JUMPL TT,IFLT3
HLRZ D,TT
MOVEI TT,(TT)
IFLT4: FSC D,255
FSC TT,233
FAD TT,D
MOVE D,IFLT9
JRST (T)
IFLT3: HLRO D,TT
HRROI TT,(TT)
AOJA D,IFLT4
DEFINE FXNV AC,FL
EFXNV!AC:
IFSN FL, , EXCH A,AC
%WTA FXNMER
IFSN FL, , EXCH A,AC
FXNV!AC: MOVEI TT-1+AC,(AC)
ROT TT-1+AC,-SEGLOG
SKIPL TT-1+AC,ST(TT-1+AC)
TLNN TT-1+AC,FX
JRST EFXNV!AC
MOVE TT-1+AC,(AC)
JRST (T)
TERMIN
IRPS A,B,[1 2-3-4-]
FXNV A,B
TERMIN
FLNV1X: AOJA T,FLNV1 ;FLNV1 WITH SKIP RETURN
EFLNV1: %WTA FLNMER
FLNV1: SKOTT A,FL
JRST EFLNV1
MOVE TT,(A)
JRST (T)
BAKPRO
RSXST: HRRZ TT,VREADTABLE ;READ CHARACTER SYNTAX
HRRZ TT,TTSAR(TT) ; TABLE SETUP
HRLI TT,((A)) ;USED AS INDIRECT ADDRESS WITH
MOVEM TT,RSXTB ;INDEX FIELD A
NOPRO
JRST (T)
SUBTTL SUPPORT FOR LAP/FASLAP CODE
REPEAT 20, CONC \20-.RPCNT,NPUSH,: PUSH P,R70
NPUSH: JRST (T) ;WRITE JSP T,NPUSH-N TO PUSH N NIL'S
REPEAT 10, CONC \10-.RPCNT,PUSH,: PUSH FXP,R70
0PUSH: JRST (T) ;WRITE JSP T,0PUSH-N TO PUSH N 0'S
REPEAT 10, CONC \10-.RPCNT,.PUSH,: PUSH FLP,R70
0.0PUSH: JRST (T) ;WRITE JSP T,0.0PUSH-N TO PUSH N 0.0'S
CINTREL: INTREL ;RANDOM USEFUL RETURN ADDRESS
INTREL: POP FXP,INHIBIT
CHECKI: SKIPN NOQUIT ;CHECKS FOR ELAYED INTRRUPTS
SKIPN INTFLG
POPJ P, ;EXIT IF NONE
JRST CKI0 ;ELSE GO PROCESS
JRST .LCAFL ;SETUP FOR FLONUM TYPE COMPILED LSUBRS
JRST .LCAFX ;SETUP FOR FIXNUM TYPE COMPILED LSUBRS
.LCALL: PUSH P,R70 ;SETUP FOR REGULAR COMPILED LSUBRS
.LCAF5: MOVN TT,T ;NUMBER OF ARGS
ADDI T,-1(P) ;ADDR OF BEGINNING OF ARG VECTOR
CAIL TT,XHINUM
JRST LXPRLZ
MOVEI A,IN0(TT)
MOVEI TT,(T) ;ARGLOC, IS RANDOM PDL PTR
JSP T,SPECBIND ;LOC. OF ARG. VECTOR STORED IN ARGLOC, WHICH
0 TT,ARGLOC ;IS TREATED LIKE SPECIAL CELL FOR ERRRET'S
0 A,ARGNUM
PUSHJ P,(D) ;PASSED TO USERS COMPILED FUN
POP P,D
SKIPN T,@ARGNUM
JRST .+3
HRLS T ;GOT TO GET RID OF THE ARGS
SUB P,T
JUMPE D,UNBIND ;THIS EXIT SIGNALS CALL TO NOTYPE LSUBR, OR NCALL TO NUMERIC
PUSH P,D
JRST UNBIND ;EXITS THRU EITHER FIX1 OR FLOAT1, MEANS REG CALL TO NUMERIC LSUBR
.LCAFX: PUSH P,CFIX1
AOJA D,.LCAF5
.LCAFL: PUSH P,CFLOAT1
AOJA D,.LCAF5
JRST CATPUS ;COMPILED CODE CALLS CATCH
ERSETUP: PUSH P,B ;COMPILED CODE CALLS ERRSET
JSP T,ERSTP
MOVEM P,ERRTN
SETZM ERRSW
SKIPE A
SETOM ERRSW
JRST (TT)
NORET: PUSHJ P,NOTNOT
HRRZM A,VNORET
POPJ P,
.RSET: PUSHJ P,NOTNOT
MOVEM A,V.RSET
POPJ P,
NOUUO: PUSHJ P,NOTNOT
HRRZM A,VNOUUO
POPJ P,
SUBTTL VARIOUS LISTING AND DE-LISTING ROUTINES
LIST: MOVEI R,CPOPJ
LIST1: MOVEI A,NIL ;BASICALLY, THE FUNCTION "LIST"
LIST1A: JUMPE T,(R)
POP P,B
PUSHJ P,XCONS
AOJA T,.-3
;;; INTERNAL LISTING FUNCTION; EVALUATES A LIST OF ARGS,
;;; STACKING THEIR VALUES ON THE PDL
KLIST: HLRZ B,(A) ;SUPER-HACKISH VERSION
PUSH P,B
HRRZ A,(A)
JLIST: HLRZ B,(A) ;HACKISH VERSION WHICH DOESN'T
PUSH P,B ; EVAL FIRST ARG OR COUNT IT
HRRZ A,(A)
ILIST: MOVEI T,0 ;CALLED BY JSP TT,ILIST
JUMPE A,(TT)
PUSH FXP,TT
PUSH FXP,T ;CONTAINS 0 - USED AS COUNTER
PUSH FXP,R ;MUST SAVE R!
ILIST1: PUSH P,A ;OTHERWISE, THIS EVAL LOOP
HLRZ A,(A) ; MAY CLOBBER ANYTHING
PUSHJ P,EVAL
ILIST3: EXCH A,(P) ;SAVE VALUE ON STACK
HRRZ A,(A)
SOS -1(FXP) ;COUNT VALUES
JUMPN A,ILIST1
POP FXP,R ;RESTORE R
POP FXP,T ;T HAS -<# OF VALUES ON PDL>
POPJ FXP,
IFN QIO,[
SUBTTL NEWIO GET READTABLE
GTRDTB: HRRZ AR2A,VREADTABLE
SKIPN V.RSET
JRST (T)
SKOTT AR2A,SA
JRST GTRDT8
MOVE TT,ASAR(AR2A)
TLNE TT,AS<RDT>
JRST (T)
GTRDT8: MOVEI AR2A,READTABLE
EXCH AR2A,VREADTABLE
EXCH AR2A,A
PUSHJ P,GTRDT9
MOVEI A,(AR2A)
JRST GTRDTB
] ;END OF IFN QIO,
SUBTTL NOINTERRUPT FUNCTION
NOINTERRUPT: JUMPE A,CHECKU ;SUBR 1 - ENABLE/DISABLE
CAIN A,QTTY
Q% JRST CHECKA
Q$ JRST CHECKU
SETO A, ; RANDOM ASYNCHRONOUS
NOINT0: EXCH A,UNREAL ; "REAL TIME" INTERRUPTS
SKIPGE A ; (CLOCKS AND TTY)
MOVEI A,TRUTH
POPJ P,
;;; CHECK FOR ANY DELAYED "REAL TIME" INTERRUPTS, AND RUN THEM
;;; IF ANY. MUST DO THEM IN THE ORDER ↑G/↑X, CLOCKS, AND OTHER.
;;; NOTE THAT AFTER A ↑G OR ↑X, CHECKU GETS CALLED AGAIN.
CHECKU: SKIPN UNREAL ;NONE CAN BE PENDING IF NOT DELAYING
Q% POPJ P,
Q$ JRST NOINT0
CHECKQ:
Q$ PUSH P,A
PUSHJ P,UINTPU
NOINT1: SKIPN (P)
JRST NOINT5
SKIPE F,UNRC.G ;PROCESS ↑G/↑X FIRST
JRST CKI2A ;TOP LEVEL OR ERRRTN WILL DO A CHECKU
NOINT5: PUSHJ P,NOINTA ;NOW PROCESS ALARMCLOCK INTERRUPTS
JRST NOINT1
NOINT3: SKIPG F,UNREAR ;NOW ANY OTHER INTERRUPTS
JRST NOINT4
SOS UNREAR
Q% MOVE A,UNREAR(F)
Q$ MOVE D,UNREAR(F)
Q$ TRNE D,400000 ;IF (NOINTERRUPT 'TTY), SUPPRESS
Q$ SKIPN (P) ; TTY INTERRUPTS AT THIS TIME
PUSHJ P,YESINT ;FOR QIO, MAY CLOBBER R (SEE UISTAK)
JRST NOINT1
NOINT4: SKIPG A,UNREAL
MOVEI A,TRUTH
Q% SETZM UNREAL
Q$ POP P,UNREAL
JRST UINTEX
IFE QIO,[
CHECKA: SKIPL UNREAL
JRST NOINT0
CHECKZ: PUSHJ P,UINTPU
PUSHJ P,NOINTA
JRST .-1
MOVEI A,QTTY
MOVEM A,UNREAL
MOVEI A,TRUTH
JRST UINTEX
] ;END OF IFE QIO
;;; DO NOT TRANSFORM THE "PUSHJ, POPJ" SEQUENCES INTO "JRST".
;;; YESINT DEPENDS ON LOOKING AT THE PUSHJ ADDRESS TO SEE WHETHER
;;; WE CAME FROM NOINTERRUPT OR ELSEWHERE!
NOINTA:
Q% SKIPN A,UNRRUN ;PROCESS RUNTIME ALARMCLOCK FIRST
Q$ SKIPN D,UNRRUN
JRST NOINT2
SETZM UNRRUN
PUSHJ P,YESINT
POPJ P,
NOINT2:
Q% SKIPN A,UNRTIM ;NOW THE REAL TIME ALARMCLOCK
Q$ SKIPN D,UNRTIM
JRST POPJ1
SETZM UNRTIM
PUSHJ P,YESINT
POPJ P,
ENOINT==. .SEE UINT0N
SUBTTL CAR/CDR ROUTINES AND FUNCTIONS
;;; HERE BELOW FOLLOW THE "FAST" CAR-CDR ROUTINES,
;;; USED WHEN *RSET=NIL, AND BY COMPILED CODE.
;;; NOTE THAT THE RELATIVE DISPLACEMENT OF THE FUNCTION ENTRY POINTS
;;; IS VERRRRRY IMPORTANT TO THE POOOR COMPLR.
;;; DONT EVER CHANGE THEM!!
CARCDR: ;INDEX NUMBER FOR CALL BY COMPILED CODE
%CADDDR: SKIPA A,(A) ; 0
%CADDAR: HLRZ A,(A) ; 1
%CADDR: SKIPA A,(A) ; 2
%CADAR: HLRZ A,(A) ; 3
%CADR: SKIPA A,(A) ; 4
%CAAR: HLRZ A,(A) ; 5
%CAR: HLRZ A,(A) ; 6
JRST (T)
%CDDDDR: SKIPA A,(A) ; 8
%CDDDAR: HLRZ A,(A) ; 9
%CDDDR: SKIPA A,(A) ;10.
%CDDAR: HLRZ A,(A) ;11.
%CDDR: SKIPA A,(A) ;12.
%CDAR: HLRZ A,(A) ;13.
%CDR: HRRZ A,(A) ;14.
JRST (T)
%CAADDR: SKIPA A,(A) ;16.
%CAADAR: HLRZ A,(A) ;17.
%CAADR: SKIPA A,(A) ;18.
%CAAAR: HLRZ A,(A) ;19.
JRST %CAAR
%CDADDR: SKIPA A,(A) ;21.
%CDADAR: HLRZ A,(A) ;22.
%CDADR: SKIPA A,(A) ;23.
%CDAAR: HLRZ A,(A) ;24.
JRST %CDAR
%CAAADR: SKIPA A,(A) ;26.
%CAAAAR: HLRZ A,(A) ;27.
JRST %CAAAR
%CDDADR: SKIPA A,(A) ;29.
%CDDAAR: HLRZ A,(A) ;30.
JRST %CDDAR
%CDAADR: SKIPA A,(A) ;32.
%CDAAAR: HLRZ A,(A) ;33.
JRST %CDAAR
%CADADR: SKIPA A,(A) ;35.
%CADAAR: HLRZ A,(A) ;36.
JRST %CADAR
;;; THE FOLLOWING TABLE IS A TRANSFER VECTOR: GIVEN THE INFO-NUMBER
;;; OF A CAR-CDR OPERATION, SAY N, THEN CARCDR[N-2] IS THE
;;; ADDRESS OF THE FAST ROUTINE FOR THAT OPERATION. NOTE THAT THE
;;; INFO-NUMBER IS NOT THE SAME AS THE INDEX-NUMBER-FOR-COMPILED-CODE
%CARCDR:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
%C!X!R
TERMIN
;;; STANDARD INTERPRETER SUBRS FOR THE VARIOUS CAR-CDR
;;; OPERATIONS. THESE CALL A CENTRAL DECODER WHICH IN *RSET
;;; MODE PERFORMS TYPE CHECKING ON THE OPERAND AT EACH STEP.
CRSUBRS:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
C!X!R: JSP F,CR0
TERMIN
;;; LET A=0, D=1, AND LET CWXYZR BE A CAR-CDR OPERATION, WITH
;;; THE VARIABLES W,X,Y,Z RANGING OVER {,A,D}. LET A NUMBER N
;;; BE COMPUTED CORRESPONDING TO CXYZWR AS FOLLOWS:
;;; N = Z + 2 IF W,X,Y ARE NULL
;;; N = Y*2 + Z + 4 IF W,X ARE NULL
;;; N = X*4 + Y*2 + Z + 10 IF W IS NULL
;;; N = W*10 + X*4 + Y*2 + Z + 20 IF NONE OF W,X,Y,Z ARE NULL
;;; NOTE TWO THINGS:
;;; [1] THIS REPRESENTATION OF A CAR-CDR OPERATION IS EASILY
;;; BITWISE DECODABLE. THE POSITION OF THE FIRST 1 BIT
;;; INDICATES THE START OF THE REST OF THE ENCODING, WHICH HAS
;;; 0 FOR CAR, 1 FOR CDR AT EACH POSITION.
;;; [2] FOR ANY SET OF OPERATIONS COMPLETE FROM CAR AND CDR,
;;; THROUGH CAAR, CADR, ... TO "LEVEL M" CAR-CDR'S (THOSE WITH
;;; M A'S AND D'S), THIS ENCODING PRODUCES A COMPACT ENCODING,
;;; M+1
;;; WITH N RANGING FROM 2 TO 2 -1 INCLUSIVE.
;;;
;;; NAME N (OCTAL) N (BINARY)
;;; CAR 2 10
;;; CDR 3 11
;;; CAAR 4 100
;;; CADR 5 101
;;; . . .
;;; CDDADR 35 11101
;;; CDDDAR 36 11110
;;; CDDDDR 37 11111
CR0: SKIPE V.RSET
JRST CR1
POP P,T
JRST @%CARCDR-<CRSUBRS+1>(F) ;QUICK VERSION OF *RSET = NIL
CR1: PUSHJ P,SAVX3 ;##### LOSS! GO AWAY WHEN COMPILER IS SMARTER.
CR1A: MOVEI D,(A)
IFN D10,[
MOVEI T,400002(F) ;400000 IS FOR CA.DER
SUBI T,<CRSUBRS+1>
] ;END OF IFN D10
.ELSE MOVEI T,400002-<CRSUBRS+1>(F) ;T GETS ENCODING "N"
CR2:
SKOTT D,LS ;CHECK FOR LIST TYPE
JRST CR4
CR3: TRNE T,1 ;SKIP IF CAR OPERATION
SKIPA D,(D)
HLRZ D,(D)
ROT T,-1
TRNE T,776 ;SKIP IF ALL DONE
JRST CR2
CR7: MOVEI A,(D)
JRST RSTX3 ;##### LOSS! GO AWAY WHEN COMPILER IS SMARTER
CR4: TRNE T,1 ;IF NEXT ARG ISN'T A LIST
SKIPA R,VCDR ;THEN CHECK OUT AGAINST PERMISSIBLITIES
MOVE R,VCAR
JUMPN R,CR5
TRNN D,-1 ;IF ONLY NIL AND LISTS PERMISSIBLE
JRST CR7 ;THEN LET NIL BECOME NIL (CAR NIL) = (CDR NIL) = NIL
JRST CA.DER ;ELSE, BOMB OUT
CR5: CAIE R,QSYMBOL
JRST CR6
TRNE D,-1
TLNE TT,SY
JRST CR3
JRST CA.DER ;LOSE IF NEITHER NIL NOR SYMBOL
CR6: CAIN R,QLIST
JRST CA.DER ;LIST TEST ON ARG HAS ALREADY FAILED, SO FAIL
JRST CR3 ;IF CAR,CDR NOT "LIST", "SYMBOL", OR "NIL", THEN OK FOR ANYTHING
SUBTTL VARIOUS LIST, SYMBOL, AND NUMBER CONSERS
PNGNK: ADDI C,PNBUF-1 ;USED ONLY BY INTERN - PURIFIES PNAME FOR BIBOP
SKIPGE LPNF
PUSHJ P,PNCONS
SKIPE V.PURE
PUSHJ P,PURCOPY
JRST SYCONS
PNGNK1: SKIPGE LPNF
PNGNK2: PUSHJ P,PNCONS
SYCONS:
BAKPRO
SKIPN FFY
JRST SYCON1
SKIPE V.PURE
JRST SYCON4
SKIPN B,FFY2
JRST SYCON1
MOVEM A,1(B)
MOVE A,[777000,,SUNBOUND]
XCTPRO
EXCH A,(B)
MOVEM A,FFY2
SYCON2: MOVSI A,(B)
EXCH A,@FFY
EXCH A,FFY
NOPRO
POPJ P,
SPECPRO INTSYX
SYCON1: PUSHJ P,AGC
JRST SYCONS
SYCON4: AOSL B,NPFFY2
SPECPRO INTSYQ
PUSHJ P,GTNPSG
ADD B,EPFFY2
AOS NPFFY2
SPECPRO INTSYP
MOVEM A,1(B)
MOVE A,[777200,,SUNBOUND]
MOVEM A,(B)
JRST SYCON2
NOPRO
;AHCONS SKIPS IN FROM ABOVE
NCONS: TRZA B,-1 ;SUBR 1 - (NCONS X) = (CONS X NIL)
XCONS: EXCH B,A ;SUBR 2 - (XCONS X Y) = (CONS Y X)
CONS: HRL B,A ;SUBR 2 - CONSTRUCT A DOTTED PAIR
SPECPRO INTC2X
CONS1: SKIPN A,FFS ;USES A,B
JRST CONS3
EXCH B,(A)
XCTPRO
CONS2: EXCH B,FFS
NOPRO
POPJ P,
SPECPRO INTC2X
CONS3: HLR A,B
PUSHJ P,AGC
NOPRO
JRST CONS1
PNCONS: PUSH FXP,T
MOVEI A,NIL
10$ SUBI C,PNBUF ;D10 CANT HAVE NEGATIVE RELOCATION
10$ MOVEI C,1(C) ;MUST CLEAR LEFT HALF OF C ALSO!
.ELSE MOVEI C,1-PNBUF(C) ;MOVEI IS FASTER THAN SUBI
PNG2: MOVE B,A
MOVE TT,PNBUF-1(C)
JSP T,FWCONS
PUSHJ P,CONS
SOJG C,PNG2
CPXTJ: JRST POPXTJ
FXCONS: ;FIXNUM CONS - MAY UNIQUIZE
FIX1A: CAIGE TT,XHINUM
CAMGE TT,[-XLONUM]
JRST FWCONS
MOVEI A,IN0(TT)
JRST (T)
SPECPRO INTZAX
FWCONS: SKIPN A,FFX ;FULL WORD CONS - ALWAYS CONSES
JSP A,AGC4
EXCH TT,(A)
XCTPRO
CONS4: EXCH TT,FFX
NOPRO
JRST (T)
FLCONX: AOJA T,FLCONS ;FLCONS WITH SKIP RETURN
SPECPRO INTZAX
FLCONS: ;FLONUM CONS
FPCONS: SKIPN A,FFL
JSP A,AGC4
EXCH TT,(A)
XCTPRO
CONS6: EXCH TT,FFL
NOPRO
JRST (T)
SUBTTL HUNK PRIMITIVES - CXR, RPLACX, HUNK<N>, HUNK, HUNKIFY
IFE HNKLOG,[
%CXR:
%RPX: LERR [SIXBIT \NO HUNKS IN THIS LISP - CXR/RPLACX!\]
] ;END OF IFE HNKLOG
IFN HNKLOG,[
CXR: JSP T,FXNV1 ;SUBR 2
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,CXR2
HLRZ A,(TT)
POPJ P,
CXR2: HRRZ A,(TT)
POPJ P,
%CXR: ROT TT,-1 ;QUICK ENTRY FOR COMPILED CALLS
ADDI TT,(A)
JUMPGE TT,%CXR2
HLRZ A,(TT)
JRST (T)
%CXR2: HRRZ A,(TT)
JRST (T)
CXR30: TLNN T,$FS+VC
JRST CXR31
CAIG TT,1
JRST (F)
CXR31: EXCH A,B
WTA [INVALID OR WRONG LENGTH HUNK!]
EXCH A,B
CXR3: MOVEI T,(B)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,HNK ;SECOND ARG MUST BE HUNK
JRST CXR30
MOVEI D,4
2DIF [LSH D,(T)]0,QHUNK1
CAMLE D,TT ;FIRST ARG MUST BE SMALLER THAN
JUMPGE TT,CXR34 ; LENGTH OF SECOND, YET NON-NEGATIVE
CXR33: WTA [BAD HUNK INDEX!]
JRST -3(F)
CXR34: MOVE D,TT
ROT D,-1
ADDI D,(B)
HRRZ T,(D)
SKIPGE D
HLRZ T,(D)
CAIN T,-1
JRST CXR33
JRST (F)
;;; IFN HNKLOG
RPLACX: JSP T,FXNV1 ;SUBR 3
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,RPLX2
HRLM C,(TT)
JRST BRETJ ;RETURN SECOND ARG
RPLX2: HRRM C,(TT)
JRST BRETJ
%RPX: ROT TT,-1 ;FOR COMPILED CODE
ADDI TT,(A)
JUMPGE TT,%RPX2
HRLM B,(TT)
JRST (T)
%RPX2: HRRM B,(TT)
JRST (T)
HNKSZ0: WTA [NOT A HUNK - HUNKSIZE!]
JRST HNKSZ1
HUNKSIZE: ;SUBR 1 - NCALLABLE
PUSH P,CFIX1
HNKSZ1: MOVEI T,(A)
LSH T,-SEGLOG
SKIPL T,ST(T)
JRST HNKSZ0
MOVEI TT,2 ;RANDOM CONSES ARE OF SIZE 2
TLNN T,HNK
POPJ P,
MOVEI D,1
2DIF [LSHC TT,(T)]0,QHUNK1-1
ADDI D,-1(A)
HNKSZ3: SETCM R,(D) ;OTHERWISE CALCULATE LENGTH
TLNE R,-1
POPJ P,
TRNE R,-1
SOJA TT,CPOPJ
SUBI D,1
SUBI TT,2
JUMPG TT,HNKSZ3
.VALUE
HUNKP: LSH A,-SEGLOG ;SUBR 1
SKIPGE A,ST(A)
TLNN A,HNK
JRST FALSE
JRST TRUE
REPEAT HNKLOG,[
SPECPRO INTZAX
CONC HUNK,\.RPCNT+1,: ;VARIOUS HUNK CONSERS
HRRZS FFH+.RPCNT ;FLUSH SIGN BIT - NEED A HUNK NOW
SKIPN A,FFH+.RPCNT
JSP A,AGC4
MOVE TT,(A)
XCTPRO
MOVEM TT,FFH+.RPCNT
REPEAT 2←.RPCNT, SETOM .RPCNT(A) ;MUST FILL OUT COMPONENTS
NOPRO ; WITH THE "UNUSED" POINTER
POPJ P,
] ;END OF REPEAT HNKLOG
;;; IFN HNKLOG
XHUNK0: WTA [BAD ARGUMENT TO MAKHUNK!]
MAKHUNK: SKOTT A,FX ;SUBR 1
JRST XHUNK5
SKIPGE TT,(A)
JRST XHUNK0
CAILE TT,2←HNKLOG ;CREATE HUNK WITH N COMPONENTS
JRST XHUNK0 ; INITIALIZED TO NIL
SOJL TT,FALSE
MOVEI T,1(TT)
PUSHJ P,XHUNK1
LSHC T,-1
JUMPE T,XHUNK6 ;BEWARE IF 1 OR 0 ELEMENTS
HRLOI T,-1(T) ;SEE HAKMEM FOR THIS EQVI HAK
EQVI T,(A)
SETZM (T)
AOBJN T,.-1
XHUNK6: SKIPGE TT
HLLZS (T)
POPJ P,
XHUNK1: JFFO TT,XHUNK2 ;SELECT CONSER FOR CORRECT SIZE HUNK
JRA A,ACONS
XHUNK2: JRST .+1-43+HNKLOG(D)
IRP X,,[1024,512,256,128,64,32,16,8,4]Y,,[9,8,7,6,5,4,3,2,1]
IFG Y-HNKLOG, .STOP
JRST HUNK!Y ;2↑<Y+1> THINGS
TERMIN
JRA A,ACONS ;2 THINGS - USE CONS
XHUNK5: JUMPGE TT,XHUNK0 .SEE LS
JSP TT,AP2 ;STACK LIST ON PDL, -COUNT IN T
HUNK: AOJG T,FALSE ;LSUBR
JUMPE T,POPNCONS
MOVNS TT,T ;CREATE HUNK BIG ENOUGH TO
MOVEI D,QHUNK ; HOLD ALL GIVEN ARGUMENTS,
CAIL TT,2←HNKLOG ; AND INSTALL THEM
JRST XHUNK7
JSP AR2A,HUNKF0
POPJ P,
XHUNK7: MOVNS T
SOJA T,WNALOSE
POPNCONS: POP P,A
JRST ACONS
HUNKF0: PUSHJ P,XHUNK1 ;CREATE A FRESH HUNK
POP P,B ;ALSO USED BY FASLOAD
HRRM B,(A) ;LAST ONE GOES IN ELEMENT 0
LSHC T,-1
MOVEI D,(A) .SEE LDLHNK
ADDI D,(T)
JUMPGE TT,HUNKF3
HUNKF2: POP P,B ;LOOP TO INSTALL ARGS IN HUNK
HRLM B,(D)
HUNKF3: SOJL T,(AR2A)
POP P,B
HRRM B,(D)
SOJA D,HUNKF2
] ;END OF IFN HNKLOG
SUBTTL ATOM, PLIST, SETPLIST, ASSOC AND FRIENDS
ATOM: LSH A,-SEGLOG ;CAN DO LSH HERE BECAUSE DON'T NEED ARG
SKIPGE ST(A) ;FALSE ONLY FOR NON-ATOMIC
TDZA A,A ; FREE-STORAGE POINTERS
MOVEI A,TRUTH
POPJ P,
LATOM: ;SKIP IF EQ TEST IS SUFFICIENT FOR EQUALITY
SPATOM: JUMPE A,1(T) ;SKIP IF NIL (WHICH IS SYMBOL)
SPAT1: SKOTT A,SY ;LEAVES TYPE BITS IN TT
JRST (T)
JRST 1(T)
PRPLSE: JUMPE A,PRPNIL
%WTA NASER
PLIST: SKOTT A,SY+LS ;SUBR 1 - FETCH PROPERTY LIST
JRST PRPLSE
HRRZ A,(A)
POPJ P,
PRPNIL: HRRZ A,NILPROPS
POPJ P,
RPLIZ: JUMPE A,RPSNIL
%WTA NASER
SETPLIST: SKOTT A,SY+LS ;SUBR 2 - SET PROPERTY LIST
JRST RPLIZ
HRRM B,(A)
POPJ P,
RPSNIL: HRRM B,NILPROPS
POPJ P,
SASSQ: SKIPA AR1,ASSQ
SASSOC: MOVEI AR1,SAS2
PUSH P,C
PUSHJ P,(AR1)
CALLF 0,@(P)
JRST POP1J
SAS2: MOVE AR1,B ;CHECK TO SEE WHETHER ASSOC CAN BE CONVERTED
JSP T,LATOM ;INTO AN ASSQ
JRST SAS3A
SAS0: SKIPE V.RSET
JSP T,SAS4
SAS1: JUMPE B,CPOPJ ;ASSOC USING AN EQ TEST, I.E. ASSQ
MOVS T,(B) ;MUST PRESERVE AR2A - SEE FASLAP
HLRZ TT,(T)
CAIN A,(TT)
JRST SAS1A
SAS1C: HLRZ B,T
JRST SAS1
SAS1A: HRRZ A,T
JUMPE A,SAS1C
SAS1B: POP P,T
JRST 1(T)
SAS3A: SKIPE V.RSET
JSP T,SAS4
SKIPA C,A
SAS3: HRRZ AR1,(AR1) ;THE FULL ASSOC THING USING EQUAL
JUMPE AR1,CPOPJ ;SAVE R - SEE SSGCPRO
MOVE A,C
HLRZ B,(AR1)
JUMPE B,SAS3
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPE A,SAS3
HLRZ A,(AR1)
JRST SAS1B
ASSOC: SKIPA T,SASSOC
ASSQ: MOVEI T,SAS0 ;** NOTE - MUST NOT USE OTHER THAN A, B, TT
PUSHJ P,(T) ;** BECAUSE OF ASSQ'S FOR READ CHAR MACROS
FALSE: MOVEI A,0
POPJ P,
SAS4: JUMPE B,(T)
SKOTT B,LS
JRST SASERR
HLRZ TT,(B)
JUMPE TT,(T)
SKOTT TT,LS+SY
JRST SASERR
JRST (T)
SUBTTL GET, GETL, PUTPROP, REMPROP FUNCTIONS
GET: SKOTT A,LS+SY
JRST GET3
CAIN B,QVALUE ;CROCK CROCK CROCK!!!!!
TLNN TT,SY
JRST GET1
JUMPE A,BOUND1
HLRZ B,(A) ;MORE CROCK MORE CROCK MORE CROCK!!!!!!
HRRZ A,(B) ; (BUT LAP DEPENDS ON IT...)
CAIN A,SUNBOUND
SETZ A,
POPJ P,
BOUND1: MOVEI A,VNIL
POPJ P,
GET3: JUMPN A,FALSE
MOVEI A,NILPROPS
CAIE B,QVALUE
JRST GET1
MOVEI A,VNIL
POPJ P,
GET0: HRRZ A,(TT) ;USES ONLY A,B,TT
JUMPE A,CPOPJ
GET1: HRRZ TT,(A) ;MUST PRESERVE C, AR1, T, D
JUMPE TT,FALSE ;(SEE EVAL AT EV3, MKNAM3, .REARRAY, AND ARRY1)
HLRZ A,(TT) ;ALSO PRESERVE R, SEE UUOH1
CAIE A,(B) ;ALSO AR2A AND F, SEE FASLOAD
JRST GET0
HRRZ TT,(TT)
HLRZ A,(TT)
POPJ P,
SARGET: MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,SA
POPJ P,
ARGET: JSP T,SPATOM ;GET ARRAY PROPERTY FROM ATOM
JSP T,PNGE1
ARGET1: MOVEI B,QARRAY
JRST GET1
PNGET: JSP T,SPATOM ;INTERNAL SUBROUTINE -GET PNAME PROP FROM ATOM
PNGT1: JSP T,PNGE
PNGT0: SKIPN A ;SAVES B
SKIPA TT,[$$$NIL]
HLRZ TT,(A) ;MUST DO IT INTO TT SO AS TO HAVE
HRRZ A,1(TT) ; CONTINUOUS GC PROTECTION
POPJ P,
.SEE CRSR40
GETLE2: %WTA NASER
GETL: SKIPN V.RSET
JRST GETL1
SKOTT B,LS
JUMPN B,GETLE
GETLA: SKOTT A,LS+SY
JRST GETL6
JRST GETL1
GETL6: JUMPN A,GETLE2
MOVEI A,NILPROPS
JRST GETL1
GETL0: HRRZ A,(A) ;USES A,B,C,T,TT
JUMPE A,CPOPJ
GETL1: HRRZ A,(A)
JUMPE A,CPOPJ
HLRZ T,(A)
SKIPA C,B
GETL4: HRRZ C,(C)
GETL3: JUMPE C,GETL0
HLRZ TT,(C)
CAIE T,(TT)
JRST GETL4
POPJ P,
PUTPROP: SKOTT A,LS+SY ;ATOM,VALUE,INDICATOR
JRST CSET7 ;OKAY TO PUTPROP ONTO NIL
CSET0C: MOVEI T,(A)
CSET0: HRRZ T,(T) ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
JUMPE T,CSET2
HLRZ TT,(T)
HRRZ T,(T)
CAIE TT,(C)
JRST CSET0
CSET0A:
PURTRAP CSET4,T, HRLM B,(T)
BRETJ:
SPROG2: MOVEI A,(B)
POPJ P,
CSET7: JUMPN A,PROPER
MOVEI A,NILPROPS
JRST CSET0C
CSET2: PUSH P,A ;ATOM DOESN'T HAVE SUCH A PROPERTY, SO
SKIPE V.PURE
JRST CSETP1
CSET2A: HRRZ A,(A)
PUSHJ P,XCONS ;CONS A FRESH ONE UP
HRRZ B,C
PUSHJ P,XCONS
POP P,C
HRRM A,(C)
$CADR: HRRZ A,(A)
HLRZ A,(A)
POPJ P,
CSET4: PUSH P,A ;FOOL PROPERTY IS IN A PURE PAGE
PUSH P,B
MOVEI T,(A)
CSET4A: HRRZ TT,(T) ;COPY ENOUGH OF THE PROPERTY LIST TO
PUSHJ P,CSET4C ; PERMIT THE PUTPROP
HLRZ A,(TT)
CAIE A,(C)
JRST CSET4A
POP P,B
POP P,A
JRST CSET0A
REMPROP: ;SUBR 2 - REMOVE PROPERTY FROM ATOMIC SYMBOL
SKOTT A,LS+SY
JRST REMP7 ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
REMP0: SKIPA D,A ;SAVE C, AR2A - SEE DEFPROP AND DEFUN
REMP1: HRRZ D,(T)
HRRZ T,(D)
JUMPE T,FALSE
MOVS TT,(T)
CAIE B,(TT)
JRST REMP1
HLRZ T,TT
REMP20: HRRZ TT,(T) ;A IS GC-PROTECTING THE ATOM
PURTRAP REMP3,D, HRRM TT,(D)
MOVEI A,(T)
POPJ P,
REMP7: JUMPN A,RMPER0
MOVEI A,NILPROPS
JRST REMP0
CSET4C: PUSHJ P,.+1 ;HAIRY WAY TO DO A DOUBLE COPY!
HRRZ A,(T)
MOVE B,(A)
PUSHJ P,CONS1
HRRM A,(T)
MOVEI T,(A)
POPJ P,
REMP3: PUSH P,A ;COME HERE ON PURE PAGE TRAP
PUSH P,B ;A ON PDL GC PROTECTS ATOM
MOVEI T,(A)
REMP3A: PUSHJ P,CSET4C ;COPY ENOUGH OF PROPERTY LIST
HRRZ TT,(T) ; TO DO REMPROP
HLRZ A,(TT)
CAME A,(P)
JRST REMP3A
HRRZ A,(TT)
HRRZ TT,(A)
HRRM TT,(T)
JRST POP2J
SUBTTL NOT, NULL, LAST, TIME, RUNTIME, BOUNDP
NOTNOT: JUMPE A,CPOPJ
JRST TRUE
NOT:
$NULL: JUMPN A,FALSE
TRUE: MOVEI A,TRUTH
CNOT: POPJ P,NOT
LAST: SKIPN T,A ;SUBR 1 - GET LAST CONS OF A LIST
POPJ P, ;RETURN NIL IF NIL
LAST1: HRRZ TT,(T) ;ELSE USE SUPER-FAST LOOP
JUMPE TT,LAST2 ; - ONLY TWO INSTRUCTIONS
HRRZ T,(TT) ; PER LIST ELEMENT SKIPPED!
JUMPN T,LAST1
SKIPA A,TT
LAST2: MOVEI A,(T)
POPJ P,
$RUNTIME: PUSH P,CFIX1
10% .SUSET [.RRUNT,,TT] ;RUNTIME IN 4. MICROSEC UNITS
10$ SETZ TT,
10$ RUNTIM TT, ;RUNTIME IN MILLISECS
10X WARN [TENEX RUNTIME?]
RNTM1:
10% LSH TT,2
10$ IMULI TT,1000.
POPJ P, ;ANSWER IN MICROSECONDS
TIME: PUSH P,CFLOAT1
IFN ITS,[
.RDTIME TT,
CAMGE TT,[72576000.] ;FOUR WEEKS OF 1/30 SEC TICS
JRST .+3
SUB TT,[72576000.]
JRST .-3
JSP T,IFLOAT
FDVR TT,[30.0]
] ;END OF IFN ITS
IFN D10,[
MSTIME TT,
IMULI TT,1000.
JSP T,IFLOAT
] ;END OF IFN D10
POPJ P,
BOUNDP: JUMPE A,TRUE
JSP T,SPATOM
JSP T,PNGE1
HLRZ T,(A) ;GET VALUE CELL
HRRZ A,(T) ;DO IT INTO T TO PROTECT FROM GC
HRRZ T,(A)
CAIN T,QUNBOUND ;RETURN VALUE CELL UNLESS UNBOUND
TDZA A,A
MOVEI A,TRUTH
POPJ P,
SUBTTL EQUAL FUNCTION
EQUAL: CAIN A,(B) ;EQ THINGS ARE EQUAL
JRST TRUE
MOVEM P,EQLP
PUSHJ P,EQUAL1 ;EQUAL1 ACTUALLY RETURNS ONLY IF EQUAL
JRST TRUE
EQUAL0: CAIN A,(B) ;EQ THINGS ARE EQUAL
POPJ P,
EQUAL1: MOVEI T,(A)
MOVEI TT,(B)
ROTC T,-SEGLOG ;GET TYPES OF ARGS
HRRZ T,ST(T)
HRRZ TT,ST(TT)
CAIE T,(TT) ;MUST HAVE SAME TYPE TO BE EQUAL
JRST EQLOSE
2DIF JRST @(T),EQLTBL,QLIST .SEE STDISP
EQLTBL: EQLLST
EQLNUM
EQLNUM
BG$ EQLBIG
EQLOSE ;PNAME ATOMS MUST BE EQ TO BE EQUAL
REPEAT HNKLOG, EQLHNK ;HUNKS REQUIRE RECURSION LIKE LISTS
EQLOSE ;RANDOMS AND NIL MUST BE EQ TO BE EQUAL
EQLOSE ;ARRAY POINTERS MUST BE EQ TO BE EQUAL
IFN .-EQLTBL-NTYPES, WARN [WRONG LENGTH TABLE]
EQLLST: PUSH P,(A)
PUSH P,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSHJ P,EQUAL0 ;COMPARE CARS
HRRZ A,-1(P)
HRRZ B,0(P)
SUB P,R70+2
JRST EQUAL0 ;COMPARE CDRS
EQLNUM: MOVE T,(A)
CAMN T,(B) ;COMPARE VALUES OF NUMBERS
POPJ P,
EQLOSE: MOVE P,EQLP ;THE ULTIMATE FALSITY - ESCAPE BACK
JRST FALSE ; TO TOP LEVEL OF ENTRY TO EQUAL WITH FALSE
IFN BIGNUM,[
EQLBIG: HLRZ T,(A)
HLRZ TT,(B)
CAIE T,(TT) ;EQUAL BIGNUMS HAVE EQ SIGNS
JRST EQLOSE ; AND CDRS ARE EQUAL LISTS OF FIXNUMS
HRRZ A,(A) ;CHECK ONLY EQUAL CDRS
HRRZ B,(B)
JRST EQUAL0
] ;END OF IFN BIGNUM
IFN HNKLOG,[
EQLHNK: PUSH P,A
PUSH P,B
MOVNI T,2
2DIF [LSH T,(TT)]0,QHUNK1
HRLI B,(T)
PUSH P,A
PUSH P,B
EQLHN1: HLRZ A,@-1(P)
HRRZ B,(P)
HLRZ B,(B)
PUSHJ P,EQUAL0
HRRZ A,@-1(P)
HRRZ B,(P)
HRRZ B,(B)
PUSHJ P,EQUAL0
MOVE T,(P)
AOBJP T,EQLHN2
MOVEM T,(P)
AOS -1(P)
JRST EQLHN1
EQLHN2: SUB P,R70+4
POPJ P,
] ;END OF IFN HNKLOG
SUBTTL NCONC, *NCONC, APPEND, *APPEND, REVERSE, NREVERSE, NRECONC
NCONC: TDZA R,R ;LSUBR - DESTRUCTIVELY CATENATE LISTS
APPEND: MOVEI R,.APPEND-.NCONC ;LSUBR - CATENATE BY COPYING
JUMPE T,FALSE
POP P,B
APP2: AOJE T,BRETJ
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,BRETJ ;SUBR 2 (*NCONC)
SKOTT A,LS
JRST NCNCER
.NCNC1: MOVEI TT,(A)
.NCNC2: MOVEI D,(TT)
HRRZ TT,(D)
JUMPN TT,.NCNC2
HRRM B,(D)
POPJ P,
.APPEND: JUMPE A,BRETJ ;SUBR 2 (*APPEND)
SKOTT A,LS
JRST APPERR
MOVEI C,AR1 ;MUST SAVE T,D - SEE MAKOBLIST
MOVE AR2A,A
APP1: HLRZ A,(AR2A)
PUSHJ P,CONS
HRRZ B,(A)
HRRM A,(C)
MOVE C,A
HRRZ AR2A,(AR2A)
JUMPN AR2A,APP1
AR1RETJ:
SUBS4: MOVEI A,(AR1)
POPJ P,
REVERSE: MOVEI C,(A) ;SUBR 1 - USES A,B,C
MOVEI A,NIL ;REVERSES A LIST BY CONSING UP A COPY
REV1: JUMPE C,CPOPJ ; OF THE TOP LEVEL IN REVERSE ORDER
HLRZ B,(C)
PUSHJ P,XCONS
HRRZ C,(C)
JRST REV1
NREVERSE: SETZ B, ;SUBR 1 - REVERSE A LIST USING RPLACD'S
NRECONC: JUMPE A,BRETJ ;SUBR 2 - (NRECONC X Y) = (NCONC (NREVERSE X) Y)
NREV1: HRRZ C,(A) ;ONLY 3 INSTRUCTIONS PER CELL! ZOOM!
HRRM B,(A)
JUMPE C,CPOPJ
HRRZ B,(C)
HRRM A,(C)
JUMPE B,CRETJ
HRRZ A,(B)
HRRM C,(B)
JUMPN A,NREV1
JRST BRETJ
SUBTTL GENSYM FUNCTION
GENSYM: JUMPN T,GENSY1
GENSY0: MOVE TT,[010700,,GNUM] ;STANDARD GENSYMER
GENSY4: MOVEI B,"0 ;WILL INCREMENT NUMERICAL PART
GENSY2: LDB T,TT ; AND GIVE OUT GENSYMED ATOM
AOS T
DPB T,TT
CAIG T,"9
JRST GENSY3
DPB B,TT
ADD TT,[070000,,0]
CAMGE TT,[350000,,]
JRST GENSY2
GENSY3: MOVE TT,GNUM
MOVEM TT,PNBUF
MOVEI C,PNBUF
JRST PNGNK2
GENSY1: MOVEI D,QGENSYM
AOJN T,S1WNALOSE
GENSY7: POP P,A
SKOTT A,FX
JRST GENSY5
MOVE TT,(A)
JUMPL TT,GENSY8
MOVE T,[010700,,GNUM]
GENSY6: IDIVI TT,10. ;INSTALL 4 DECIMAL DIGITS
ADDI D,"0 ; IN GENSYM COUNTER
DPB D,T
ADD T,[070000,,0]
CAMGE T,[350000,,]
JRST GENSY6
JRST GENSY3
GENSY5: TLNN TT,SY
JUMPN A,GENSY8
JSP T,CHNV1D
DPB TT,[350700,,GNUM]
JRST GENSY4
SUBTTL MEMBER, MEMQ, SUBST, DELQ, DELETE, *DELQ, *DELETE
MEMBER: SETZM MEMV ;USES A,B,AR1,AR2A,T,TT
MOVEI AR1,(A)
MOVEI AR2A,(B)
JSP T,LATOM
JRST MEMB1
SMEMQ: SETZM MEMV ;USES A,B,T,MUST PRESERVE AR1,AR2A;SEE GTSPC3
MEMQ2: SKOTT B,LS
JRST FALSE
HLRZ T,(B)
CAMN A,T
JRST SPROG2
HRRM B,MEMV
HRRZ B,(B)
JRST MEMQ2
MEMB1: SKOTT AR2A,LS
JRST FALSE
MOVE A,AR1
HLRZ B,(AR2A)
PUSHJ P,EQUAL
JUMPN A,MEMB2 ;TRUE
HRRM AR2A,MEMV
HRRZ AR2A,(AR2A)
JRST MEMB1
AR2ARETJ:
MEMB2: MOVEI A,(AR2A)
POPJ P,
SUBST: SKIPA AR1,A
SUBS0A: SKIPA A,AR1
SKIPA AR2A,B
MOVE B,AR2A
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,AR1RETJ
SUBS1: MOVE A,C
PUSHJ P,ATOM
JUMPE A,SUBS2
CRETJ:
SPROG3: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
SUBS3: POP P,B
JRST XCONS
DELQ: SKIPA D,[SMEMQ] ;USES A,B,C,T,TT. MUST SAVE AR2A - SSMACRO
DELETE: MOVEI D,MEMBER ;USES A,B,C,AR1,AR2A,T,TT
MOVEI TT,-1 ;MUST SAVE R, SEE GCP6H1
CAMN T,XC-2
JRST DLT3
CAME T,XC-3
JRST DLT6
POP P,A
JSP T,FLTSKP
JRST .+2
JSP T,IFIX
DLT3: MOVEM TT,DLTC
MOVEI TT,(P)
SKIPA B,(P)
DLT2: HRRM B,(TT)
MOVEM TT,TABLU1
MOVE A,-1(P)
SOSGE DLTC
JRST DLT1
PUSHJ P,(D) ;MEMBER OR MEMQ
JUMPE A,DLT1
HRRZ B,(A)
SKIPN TT,MEMV
MOVE TT,TABLU1
JRST DLT2
DLT1: POP P,A
JRST POP1J
.DELQ: SKIPA D,[SMEMQ]
.DELETE: MOVEI D,MEMBER
PUSH P,A
PUSH P,B
MOVEI TT,-1
JRST DLT3
MEMQ: JUMPE B,FALSE
HLRZ T,(B)
CAIN T,(A)
JRST BRETJ
HRRZ B,(B)
JRST MEMQ
SUBTTL FLOATP, FIXP, NUMBERP, TYPEP, AND PDLNMK ROUTINE
IRP NUMP,,[FIXP,FLOATP,NUMBERP]BITS,,[FX+BN,FL,FX+FL+BN]
NUMP: SKOTT A,BITS
JRST FALSE ;RETURN NIL IF NOT OF DESIRED TYPE
MOVE TT,(A) ;RETURN T IF WHAT WE WANT. ALSO, TT GETS THE NUMBER.
JRST TRUE ;IF NUMBERP GETS A BIGNUM, TT GETS THE CORRECT SIGN, ANYWAY
TERMIN
TYPEP: JUMPE A,TYPNIL ;SUBR 1 - USES ONLY A
ROT A,-SEGLOG
HRRZ A,ST(A)
POPJ P,
TYPNIL: MOVEI A,QSYMBOL
POPJ P,
NMCK0: POP P,A
NUMCHK: ;CHECK TO SEE THAT WE HAVE A NUMBER, THEN EXIT
BG% JSP T,FLTSKP
BG$ JSP T,NVSKIP
BG$ POPJ P,
JFCL ;FALLS INTO PDLNKJ
PDLNKJ: MOVEI T,CPOPJ ;PDLNKJ = PDLNMK, THEN POPJ P,
PDLNMK: CAML A,NPDLL
CAMLE A,NPDLH
JRST (T)
ROT A,-SEGLOG
SPECPRO INTROT
HLL T,ST(A)
ROT A,SEGLOG
NOPRO
TLNN T,$FXP+$FLP ;SKIP IFF PDL NUMBER
JRST (T)
PUSH P,T
NMK1: MOVEM TT,PNMK1 ;EXPECTS TYPE BITS IN T
MOVE TT,(A)
HRRI T,PNMK2 ;MUST SAVE TT
TLNN T,$FLP ;FIGURE OUT WHICH KIND OF CONS TO DO
JRST FXCONS ; - FIXNUM
JRST FLCONS ; - FLONUM
PNMK2: MOVE TT,PNMK1 ;RESTORE TT FOR PDLNMK
CPDLNKJ: POPJ P,PDLNKJ
SUBTTL GCPRO AND SXHASH
GCPRO: JUMPE B,GCREL
CAIN B,QM ;SECOND ARG = ? MEANS ONLY GCLOOK
JRST GCLOOK
%GCPRO: MOVEI AR1,1 ;MUST SAVE R,F - FOR FASLOAD
GCPR1: CAIL A,IN0-XLONUM
CAILE A,IN0+XHINUM-1
JRST .+2
POPJ P,
SKOTT A,SY
JRST GCPR2
JUMPLE AR1,CPOPJ
HLRZ T,(A)
MOVSI TT,100 ;COMPILED CODE NEEDS ME BIT
MOVSI D,200 ;PURE SYMBOL BLOCK BIT
TDNN D,(T)
IORM TT,(T)
POPJ P,
GCPR2: MOVE AR2A,A ;SAVE ARG
PUSHJ P,SXHSH0 ;LEAVES HASHKEY IN D
MOVE A,AR2A
MOVE T,AR1 ;T=0 => RELEASE, ELSE PROTECT
.GCPRO: JUMPE A,CPOPJ
LOCKI
PUSH P,A ;PLACES ORIG ARG ON PDL
PUSHJ P,SAVX5 ;SAVES NUM ACS
SKIPE B,GCPSAR
JRST .GCPR5
MOVEI A,NIL
MOVE TT,LOSEF
ADDI TT,1
LSH TT,-1
PUSHJ P,MKLSAR
MOVE D,-2(FXP) ;RESTORE HASHKEY IN D
MOVEM B,GCPSAR
.GCPR5: MOVE T,D ;ARG ON P, AND SAVES NUM ACS ON FXP
LSH T,-1
IDIV T,LOSEF
PUSH FXP,TT
MOVEI A,(FXP)
PUSHJ P,@ASAR(B)
SUB FXP,R70+1
MOVEM R,-3(FXP)
MOVE B,A
MOVE A,(P) ;ORIG ARG ON P
PUSH P,B ;SAVE PROLIST BUCKET
SKIPN -4(FXP)
JRST GCRL1 ;GO RELEASE IF FLAG SO SET.
PUSHJ P,MEMBER
JUMPN A,GCPR3 ;ITEM ALREADY IN PROTECTIVE BUCKET
SKIPG -4(FXP)
JRST GCPR4
MOVE A,-1(P) ;ORIGINAL ARG
MOVE B,(P) ;CONSED ONTO PROLIST BUKET
PUSHJ P,CONS
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
GCPR3: HLRZ A,(A)
GCPR4: PUSHJ P,RSTX5
SUB P,R70+2
UNLKPOPJ
GCRL1: CALLF 2,QDELETE ;GCRELEASE
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
JRST GCPR4
GCREL: TDZA AR1,AR1
GCLOOK: MOVNI AR1,1
SKIPN GCPSAR
JRST FALSE
JRST GCPR1
SXHASH: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE
PUSHJ P,SXHSH0 ;SAVE F - SEE DEFUN
MOVE TT,D
POPJ P,
ATMHSH: ;HASH A PRINT NAME
BNHSH: SETZ T, ;HASH A BIGNUM (SAME ALGORITHM)
SKIPA B,A
AHSH1: HRRZ B,(B)
JUMPE B,AHSH2
HLRZ C,(B)
XOR T,(C)
JRST AHSH1
AHSH2: LSH T,-1 ;FOR ATOMS, THIS INSURES THAT THE HASHKEY IS POSITIVE
JRST (TT)
NILHSH: MOVE D,[<ASCII \NIL\>←-1] ;HASH NIL FASTLY
POPJ P,
SXHSH0: JUMPE A,NILHSH ;RETURNS S-EXPR'S HASHKEY IN D
SKOTT A,LS
2DIF JRST @(TT),SXHSH9-1,QLIST .SEE STDISP
HRRZ B,(A)
PUSH P,B
HLRZ A,(A)
PUSHJ P,SXHSH0
ROT D,-1
PUSH FXP,D
POP P,A
PUSHJ P,SXHSH0
POP FXP,T
ADD D,T
POPJ P,
SXHSH8: MOVM D,(A) ;FLONUM
POPJ P,
SXHSH7: MOVE D,(A) ;FIXNUM
POPJ P,
IFN BIGNUM,[
SXHSH4: HRRZ A,(A) ;BIGNUM
JSP TT,BNHSH
MOVE D,T
POPJ P,
] ;END OF IFN BIGNUM
SXHSH5: HLRZ T,(A) ;SYMBOL
HRRZ A,1(T)
JSP TT,ATMHSH
SKIPA D,T
SXHSH6: MOVEI D,(A)
POPJ P, ;RANDOM, ARRAY
SXHSH9: SXHSH7 ;FIXNUM
SXHSH8 ;FLONUM
BG$ SXHSH4 ;BIGNUM
SXHSH5 ;SYMBOL
REPEAT HNKLOG, SXHS1A ;HUNKS
SXHSH6 ;RANDOM
SXHSH6 ;ARRAY
IFN .-SXHSH9-NTYPES+1, WARN [WRONG LENGTH TABLE]
IFN HNKLOG,[
SXHS1A: MOVSI T,-2
2DIF [LSH T,(TT)]0,QHUNK1
PUSH P,A
HRRI T,(A)
PUSH P,T
PUSH FXP,R70
SXHS1B: HLRZ A,(T)
PUSHJ P,SXHSH0
ROT D,1
ADDM D,(FXP)
MOVE T,(P)
HRRZ A,(T)
PUSHJ P,SXHSH0
ADD D,(FXP)
ROT D,2
MOVEM D,(FXP)
MOVE T,(P)
AOBJP T,SXHS1F
MOVEM T,(P)
JRST SXHS1B
SXHS1F: SUB P,R70+2
JRST POPXDJ
] ;END OF IFN HNKLOG
SUBTTL MAPPING FUNCTIONS
;;; MAPATOMS FUNCTION
;;; (MAPATOMS FN) CALLS FN REPEATEDLY, FEEDING IT SUCCESSIVE
;;; ATOMS FROM THE CURRENT OBARRAY. OPTIONAL SECOND ARG
;;; SPECIFIES OBARRAY (MUST BE A SAR!). RETURNS NIL.
MAPATOMS:
MOVEI D,QMAPATOMS
AOJG T,S1WNALOSE
AOJL T,S2WNALOSE
SKIPE T ;SECOND ARG DEFAULTS TO
PUSH P,VOBARRAY ; CURRENT OBARRAY
MOVEI TT,(CALL 1,)
HRLM TT,-1(P)
PUSH P,R70
PUSH FXP,[OBTSIZ] ;NUMBER OF BUCKETS
MAPAT1: SOSGE TT,(FXP) ;TT GETS BUCKET NUMBER
JRST MAPAT9
HRRZ AR1,-1(P)
ROT TT,-1
HLRZ A,@TTSAR(AR1) ;FETCH BUCKET
SKIPGE TT
HRRZ A,@TTSAR(AR1)
MOVEM A,(P) ;SAVE BUCKET
MAPAT2: SKIPN B,(P) ;MAPCAR DOWN BUCKET
JRST MAPAT1
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,(P)
XCT -2(P) ;CALL SUPPLIED FUNCTION
JRST MAPAT2
MAPAT9: SUB FXP,R70+1 ;EXIT, RETURNING NIL
SUB P,R70+3
JRST FALSE
;;; PDL STRUCTURE FOR MAP SERIES
;;; ,,RETURN ;LEFT HALF MAY HAVE BAKTRACE INFO
;;; ,,EVENTUAL VALUE ;LEFT HALF HAS LAST OF VALUE LIST
;;; LIST1 ;SECOND ARG
;;; LIST2 ;THIRD ARG
;;; LIST3 ;FOURTH ARG
;;; ...
;;; LISTN ;LAST ARG
;;; -N,,<ADDRESS OF LIST1 ON STACK>
;;; CODE,,MODE ;CODE TELLS WHAT KIND OF MAP, MODE TELLS HOW TO CALL FN
;;; ; (MODE IS ADDRESS OF PLACE WHICH SETS UP ARGS FOR FN)
;;; MAPL6 ;OR MAYBE MAPL3 - THIS IS WHERE FN CALL RETURNS TO
;;; JCALL K,FN ;FN=FIRST ARG - K=1,2,3,4,5, OR 16
;;; ;UUO HANDLER MAY CLOBBER THIS WITH A JRST
;;; ;IF NEVER GOING TO BE XCT'ED, JCALL NEED NOT BE THERE
MAPLIST: JSP TT,MAPL0 ;CODE 0
MAPCAR: JSP TT,MAPL0 ;CODE 1
MAP: JSP TT,MAPL0 ;CODE 2
MAPC: JSP TT,MAPL0 ;CODE 3
MAPCON: JSP TT,MAPL0 ;CODE 4
$MAPCAN: JSP TT,MAPL0 ;CODE 5
MAPL0: AOJGE T,MAPWNA ;LOSE IF ONLY ONE ARG
MOVE D,T
ADDI D,1(P) ;D HAS ADDRESS OF LIST1 ON STACK
HRLI D,(T)
PUSH P,D
10$ SUBI TT,MAPLIST ;LOSING D10 DISALLOWS
10$ MOVSI TT,-1(TT) ; NEGATIVE RELOCATION
.ELSE MOVSI TT,-MAPLIST-1(TT) ;FIGURE OUT CODE FOR WHICH KIND OF MAP
PUSH P,TT ;SAVE CODE - FIGURE OUT MODE LATER
TLNE TT,2 ;SKIP IF WE'LL BE SAVING UP RESULTS
SKIPA A,(D) ;ELSE WE'LL JUST RETURN FIRST LIST AS VALUE
MOVSI A,-1(D)
EXCH A,-1(D) ;INIT EVENTUAL VALUE SLOT - A NOW HAS FIRST ARG (FN)
JSP T,SPATOM
JRST MAPL5 ;FOOEY, IT'S NOT A SYMBOL
HRRZ C,(A)
MAPL1: JUMPE C,MAPL5 ;FOOEY, IT'S A SYMBOL WITH NO FUNCTION PROPERTY
HLRZ B,(C)
HRRZ C,(C)
HRRZ C,(C)
CAIL B,QARRAY ;REMEMBER, SYMBOLS DENOTING FUNCTION PROPS
CAILE B,QFEXPR ; ARE CONSECUTIVE IN SYMBOL SPACE
JRST MAPL1
CAIE B,QARRAY
CAIN B,QSUBR
JRST MAPL5A ;GO FIGURE OUT JCALL FOR A SUBR OR ARRAY
CAIE B,QLSUBR
JRST MAPL5 ;FOOEY, IT'S SOMETHING WE CAN'T LINK TO WELL
PUSH P,CMAPL3
HRLI A,(JCALL 16,)
MOVEI B,MAPL23
MAPL1B: HRRM B,-1(P) ;B HAS MODE - SAVE IT
PUSH P,A ;SAVE FN (MAYBE WITH JCALL K, IN LEFT HALF)
JRST MAPL2
MAPL3: MOVE D,(P) ;GET FUNCTION CALL FROM STACK
TLNE D,700000 ;SKIP IF IT DIDN'T GET CLOBBERED
JRST MAPL3A
MOVEI D,MAPL24 ;OH, WELL! MIGHT AS WELL USE MODE
HRRM D,-2(P) ; FOR UNCLOBBERABLE FNS
CMAPL6:
MAPL3A: MOVEI D,MAPL6
MOVEM D,-1(P) ;WE ONLY NEED TO DO A MAPL3 CHECK ONCE
MAPL6: MOVE D,-3(P) ;D POINTS TO LIST1 ON STACK
HLRZ C,-1(D) ;C GETS POINTER TO LAST OF VALUE
JUMPE C,MAPL7 ;THIS IS REALLY A MAP OR MAPC
HLLZ B,-2(P) ;GET CODE IN LAFT HALF OF B
TLNE B,4
JRST MAPL8 ;MAPCAN OR MAPCON
PUSHJ P,CONS ;MAPCAR OR MAPLIST - NOTE THAT B IS NIL
HRRM A,(C) ;CLOBBER INTO END OF LIST
MAPL6A: HRLM A,-1(D) ;SAVE NEW LAST POINTER
MAPL7: MOVE TT,(D)
MAPL7A: HRRZ A,(TT) ;TAKE CDR OF ALL LISTS
MOVEM A,(D)
SKIPL TT,1(D)
AOJA D,MAPL7A
MOVE D,TT ;NOW D POINTS TO LIST1 ON STACK AGAIN
MAPL2: MOVE B,-2(P)
MOVE C,P ;SAVE C FOR A QUICK GETAWAY
PUSH P,-1(P) ;WHERE CALL TO FN SHOULD RETURN
MAPL21: SKIPG A,(D) ;D POINTS TO VECTOR OF LISTS
JRST MAPL22 ;REMEMBER, <-N,,XXX> IS JUST AFTER <LISTN>
MOVEI TT,(A)
LSH TT,-SEGLOG
SKIPL ST(TT) ;END-OF-LIST TEST
JRST MAPL40
TLNE B,1 ;SKIP UNLESS THIS IS A "CAR" KIND OF MAP
HLRZ A,(A)
PUSH P,A ;PUSH ARG
AOJA D,MAPL21 ;IF NOT END, GO CHECK OUT NEXT LIST
MAPL40: JUMPE A,MAPL4
LER3 [SIXBIT \NON-NULL TERMINATION OF LIST - MAP\]
MAPL4: MOVE P,C ;THIS POPS OFF FASTLY ANY UNNEEDED STUFF
HLRZ T,-3(P) ;GET -N IN T
SUBI T,4
HRLI T,-1(T)
ADD P,T ;FASTLY POP OFF FN, MODE, ALL LISTS, ETC.
POP P,A ;FINAL VALUE GOES IN A
TLZ A,-1 ;ZERO ANY LEFT HALF GARBAGE
CMAPL3: POPJ P,MAPL3 ;HOORAY!
MAPL22: JUMPE A,MAPL4 ;NIL IS NORMAL END-OF-LIST
SETZB A,B ;MAY HAVE GARBAGE IN LEFT HALVES
HLRE T,(D) ;T GETS -N IN CASE OF LSUBR CALL
MOVE TT,1(D) ;GET MODE (D POINTS TO <-N,,XXX> ON STACK)
JSP R,(TT) ;FOR SUBRS, GOES TO PDLA2-N
MAPL23: XCT 3(D) ;GO HERE FOR LSUBRS
MAPL24: MOVEM T,UUTSV ;GO HERE FOR UNCLOBBERABLE CALL
MOVE T,3(D) ;SAVE SOME OF THE UUOH TROUBLE BY
HRLI T,(JCALLF 16,) ; ENTERING THE UUO MESS MORE DIRECTLY
MOVEM T,40
TLZ T,-1
MOVEI R,1 ;R=1 MEANS LSUBR CALL
SETZM UUOH
JRST UUOH0A
MAPL5: PUSH P,CMAPL6 ;SET UP FOR UNCLOBBERABLE FN CALL
MOVEI B,MAPL24
JRST MAPL1B
MAPL5A: HLRE T,-1(P)
CAMGE T,XC-5 ;CHECK NUMBER OF ARGS FOR FN
JRST MAPL5 ;FOOEY, TOO MANY ARGS FOR SUBR CALL
PUSH P,CMAPL3
MOVM TT,T
LSH TT,5
TLO A,(JCALL)(TT) ;MAKE UP JCALL OF RIGHT # OF ARGS
MOVEI B,PDLA2(T) ;MODE = PDLA2-<# OF ARGS>
JRST MAPL1B
MAPL8: JUMPE A,MAPL7 ;NCONC'ING NIL DOES VERY LITTLE
HRRM A,(C) ;CLOBBER INTO LAST OF PREVIOUS THING
PUSHJ P,LAST ;FIND LAST OF THIS NEW FROB
JRST MAPL6A
.MAP: JSP TT,.MAP1 ;MAPCAN
JSP TT,.MAP1 ;MAPCON
JSP TT,.MAP1 ;MAPC
JSP TT,.MAP1 ;MAP
JSP TT,.MAP1 ;MAPCAR
JSP TT,.MAP1 ;MAPLIST
.MAP1: JUMPE A,CPOPJ
TLNE A,-1 ;RIDICULOUS CHECK FOR HORRIBLE
.VALUE ; COMPILER LOSSES
PUSH P,B ;LIST IN A, FUNCTION IN B,
PUSH P,A ;NUMBER IN TT IS INDEX
MOVNI T,2
10$ SUBI TT,.MAP+A ;LOSING D10!!!
10$ MOVNS TT ;NO NEGATIVE RELOC ALLOWED!
.ELSE MOVNI TT,-.MAP-A(TT)
JRST $MAPCAN(TT)
SET: JSP D,SETCK
EXCH B,AR1
JSP T,.SET1
EXCH B,AR1
POPJ P,
%WTA NASER
SETCK: JSP T,SPATOM
JRST .-2
JRST (D)
SUBTTL VARIOUS BREAK ROUTINES
$BREAK: JUMPE A,CPOPJ ;*BREAK - SUBR 2
$BRK0: MOVEI A,(B) ;A = BREAKP, B = BREAKID
HRRZ B,V.
MOVEI C,TRUTH
HRRZ AR1,VIPLUS
HRRZ AR2A,VIDIFF
JSP T,SPECBIND ;DO *NOT* BIND ↑R
TAPRED ;↑Q
TTYOFF ;↑W
Q% TYIMAN
Q% TMBBC
VEVALHOOK ;EVALHOOK
0 B,V. ;*
0 C,V%TERPRI
0 AR1,VIPLUS ;+
0 AR2A,VIDIFF ;-
IFN QIO,[
MOVEI B,$DEVICE
MOVEI C,UNTYI
;; MOVEI AR1,READP
;; MOVEI AR2A,UNRD
JSP T,SPECBIND
0 B,TYIMAN
0 C,UNTYIMAN
;; 0 AR1,READPMAN
;; 0 AR2A,UNREADMAN
] ;END OF IFN QIO
Q% SETZM RDOBCT
STRT 17,[SIXBIT \↑M;BKPT !\]
Q% PUSHJ P,PRINC ;PRINC BREAK ID
Q$ HRRZ AR1,VMSGFILES
Q$ TLO AR1,200000
Q$ PUSHJ P,$PRINC
STRT 17,STRTCR
MOVE A,VIDIFFERENCE
MOVEM A,VIPLUS
MOVEI D,BRLP ;FUNCTION TO EXECUTE
PUSHJ P,BRGEN ;CATCH AND ERRSET AROUND A READ-EVAL-PRINT LOOP
Q% SKIPN LINMODE
Q$ JSP F,LINMDP
PUSHJ P,ITERPRI
Q$ PUSHJ P,UNBIND
JRST UNBIND
CB: SKIPN V.RSET ;CALL BREAK - *RSET ERROR
POPJ P,
SKIPA B,[Q.R.TP]
Q% CN.HB: MOVEI B,QCN.H ;CONTROL-H BREAK
Q$ CN.BB: MOVEI B,QCN.B ;CONTROL-B BREAK
PUSHJ P,IOGBND
Q$ PUSH P,CUNBIND
JRST BKCOM2
UDFB: MOVEI B,QUDF ;UNDEFINED FUNCTION BREAK
JRST BKCOM
UBVB: MOVEI B,QUBV ;UNBOUND VARIABLE BREAK
JRST BKCOM
WTAB: MOVEI B,QWTA ;WRONG TYPE OF ARGUMENT BREAK
JRST BKCOM
UGTB: MOVEI B,QUGT ;UNSEEN GO TAG BREAK
JRST BKCOM
WNAB: MOVEI B,QWNA ;WRONG # ARGS BREAK
JRST BKCOM
GCLB: MOVEI B,QGCL ;FAILED TO GARBAGE-COLLECT ENOUGH SPACE BREAK
JRST BKCOM
PDLB: MOVEI B,QPDL ;PDL OVERFLOW BREAK
JRST BKCOM
GCOB: MOVEI B,QGCO ;GC OVERFLOW BREAK
JRST BKCOM
Q$ IOLB: MOVEI B,QIOL ;I/O LOSSAGE BREAK
Q$ JRST BKCOM
FACB: MOVEI B,QFAC ;FAILED ACTION REQUEST BREAK
BKCOM:
Q% PUSHJ P,IOGBND
SAVE A B
Q% MOVEI A,NIL
Q% PUSHJ P,ERRPRINT
IFN QIO,[
PUSH P,CBKCM0
PUSH P,R70
PUSH P,VMSGFILES
MOVNI T,2
JRST ERRPRINT
BKCOM0:
] ;END OF IFN QIO
JSP R,RSTR2
BKCOM2: MOVEI AR1,READTABLE
MOVEI AR2A,OBARRAY
JSP T,SPECBIND
0 A,VARGS ;SPECIAL VALUE CELL OF ARGS
0 AR1,VREADTABLE ;RESET READTABLE AND OBARRAY
0 AR2A,VOBARRAY ; TO STANDARD (INITIAL) ONES
Q% SETZ A,
Q$ CBKCM0: SETZ A,BKCOM0
PUSHJ P,NOINTERRUPT
MOVEI A,TRUTH
PUSHJ P,$BREAK
BKCOM1:
Q% PUSHJ P,UNBIND
JRST UNBIND
SUBTTL INTERN FUNCTION AND RELATED ROUTINES
INTERN: PUSH P,A ;ONLY INIT ENTERS INTERN AT INTRN0
INTRN3: PUSHJ P,PNGET ;MUST SAVE F - SEE FASLOAD
SETOM LPNF
INTRN1: SETZM RINF
JSP TT,ATMHSH ;LEAVES ATOM'S HASHKEY IN T
MOVEI AR2A,(A)
HLRZ C,(A)
INTRN: TLZ T,400000
IDIVI T,OBTSIZ
HRLM TT,(P)
INTRN4: LOCKI ;SO THAT NO INTERRUPT SNEAKS SOMETHING
SKIPN D,VOBARRAY ; ON THE OBLIST JUST AFTER WE DECIDE IT ISNT THERE
JRST INTNCO
MOVEI C,(D)
LSH C,-SEGLOG
MOVE C,ST(C)
TLNN C,SA
JRST INTNCO
MOVE T,ASAR(D)
TLNN T,AS<OBA>
JRST INTNCO
ROT TT,-1 ;GET BUCKET
JUMPL TT,.+3
HLRZ A,@TTSAR(D)
JRST .+2
HRRZ A,@TTSAR(D)
PUSH FXP,TT
JUMPE A,MAKA0
MOVEI C,A
MAKF: MOVE AR1,C
HRRZ C,(C)
JUMPE C,MAKA
HLRZ AR1,(C)
SKIPN AR1
TROA AR1,$$$NIL ;BEWARE THE SKIP!
MAKF1: HLRZ AR1,(AR1)
HRRZ AR1,1(AR1)
SKIPN T,RINF ;RINF HAS ZERO WHEN IN REGULAR INTERN
MOVEI T,(AR2A)
MAK2: JUMPE AR1,MAK1
JUMPE T,MAKF
HLRZ B,(AR1)
MOVE B,(B)
SKIPN RINF
JRST MAK4
CAME B,@RNTN2 ;<END OF PNAME>(T)
JRST MAKF ;COMPARE FOR RINTERN
AOJA T,MAK3
MAK4: HLRZ D,(T) ;COMPARE FOR REGULAR INTERN
CAME B,(D)
JRST MAKF
HRRZ T,(T)
MAK3: HRRZ AR1,(AR1)
JRST MAK2
MAKA3: HRRZ A,(P)
SKIPL LPNF
PUSHJ P,SYCONS
JRST MAKA2
MAKA0: TDZA D,D ;D=0 => BUCKET WAS EMPTY BEFORE THIS CALL
MAKA: MOVEI D,1
MOVN C,RINF ;MAKE-UP NEW ATOM
JUMPE C,MAKA3
PUSHJ P,PNGNK
MAKA2: PUSHJ P,NCONS
MOVE TT,(FXP)
JUMPE D,MAKA5
HRRM A,(AR1) ;NCONC ONTO END OF BUCKET
JRST MAKA4
MAKA5: HRRZ D,VOBARRAY
JUMPL TT,.+3
HRLM A,@TTSAR(D)
JRST .+2
HRRM A,@TTSAR(D)
MAKA4: SKIPA C,A
MAK1: JUMPN T,MAKF ;ATOM FOUND ON OBLIST
HLRZ A,(C)
POP FXP,TT ;SHOULD EXIT WITH OBTBL BUCKET # IN TT
SUB P,R70+1
UNLKPOPJ
RINTERN: CAMN C,[350700,,PNBUF]
JRST RINTN1
RINTN0: PUSH FXP,T
PUSH P,CPXTJ
PUSH P,A ;ENTERING INTERN AFTER THE "PUSH P A", SO MUST DO HERE
SKIPL LPNF
JRST INTRN1
ADDI C,1
HRRM C,RNTN2
10% MOVEI C,-PNBUF(C) ;MOVEI IS FASTER THAN SUBI
10$ SUBI C,PNBUF ;FOOBAR! NO NEG RELOC ALLOWED FOR D10
10$ TLZ C,-1 ;MAY BE CRUFT IN LH (LIKE BYTE POINTER)
MOVNM C,RINF
INTRN2: MOVEI C,PNBUF ;DUPLICATE PNAME HASHING ALGORITHM
MOVE T,PNBUF ; AS USED IN SXHASH
MOVN D,RINF
SOJLE D,.+3
XOR T,PNBUF(D)
JRST .-2
LSH T,-1
JRST INTRN
RINTN1: SKIPL LPNF
JRST RINTN0
MOVE TT,PNBUF
ROT TT,6
ADDI TT,<OBTSIZ+1>/2 ;### OBTSIZ MUST BE ODD
MOVE D,VOBARRAY
JUMPL TT,.+3
HLRZ A,@1(D)
JRST .+2
HRRZ A,@1(D)
JUMPN A,CPOPJ
PUSH FXP,TT
PUSHJ P,RINTN0
POP FXP,TT
MOVE D,VOBARRAY
JUMPL TT,.+3
HRLM A,@1(D)
POPJ P,
HRRM A,@1(D)
POPJ P,
IMPLODE: SKIPA T,CRINTERN ;SUBR 1
MAKNAM: MOVEI T,PNGNK1 ;SUBR 1
JUMPE A,MKNM4
PUSH P,T
Q% PUSH P,MKNM3
Q% HRRZM A,MKNM3
Q$ PUSH P,RDLARG
Q$ HRRZM A,RDLARG
MOVEI T,MKNM1
PUSHJ FXP,MKNR6C
Q% POP P,MKNM3
Q$ POP P,RDLARG
CRINTERN: POPJ P,RINTERN
IFN QIO,[
MKNM1: SKIPN A,RDLARG
POPJ P,
HRRZ B,(A)
MOVEM B,RDLARG
HLRZ A,(A)
MKNM2: JSP T,CHNV1
JRST POPJ1
] ;END OF IFN QIO
IFE QIO,[
MKNM1: SKIPN B,MKNM3 ;GET NEXT CHAR FOR MAKNAM
JRST FALSE
MKRL1: HRRZ A,(B)
HRRM A,MKNM3
HLRZ A,(B) ;B HOLDS LIST FROM WHICH TO GET NEXT CHAR FOR
JSP T,CHNV1
MOVEI A,(TT)
POPJ P,
] ;END OF IFE QIO
RDL12: MOVEI T,RINTERN
MKNM4: SETZM PNBUF
JSP TT,IRDA
JRST (T) ;PNGNK1 OR RINTERN, THEN POPJ P,
;;; GET CHARACTER NUMERIC VALUE
CHNV1X: TLO T,1
CHNV1: SKOTT A,SY+FX
JRST CHNV1C
TLNN TT,SY
JRST CHNV1A
CHNV1D: HLRZ TT,(A)
HRRZ TT,1(TT)
HLRZ TT,(TT)
LDB TT,[350700,,(TT)]
JRST CHNV1B
CHNV1A: MOVE TT,(A)
TLNN T,1
CHNV1B: TDNN TT,[-200]
JRST (T)
CHNV1C: WTA [NOT ASCII CHARACTER!]
JRST CHNV1
SUBTTL DEFPROP AND DEFUN
DEFPROP: PUSH P,A
JSP T,DFPR2
JSP T,DFPR1
JRST DFPER
HRRZ TT,(C)
JUMPN TT,DFPER
HLRZ A,(A)
HLRZ AR1,(B)
HLRZ B,(C)
MOVEI C,(B)
DEF1: MOVEI AR2A,(A)
DEF1B: PUSHJ P,REMPROP ;REMPROP SAVES C, AR1, AR2A
MOVEI B,(AR1)
JUMPN A,DEF1B ;REMOVE ALL OCCURRENCES OF THE PROPERTY
MOVEI A,(AR2A)
PUSHJ P,PUTPROP
DEF9: POP P,A
$CAR: HLRZ A,(A)
C$CAR: POPJ P,$CAR
DFPR2: HLRZ B,(A) ;SOME HAIRY CHECKS FOR DEFPROP AND DEFUN
SKOTT B,SY
JUMPN B,1(T)
JRST (T)
DFPR1: JUMPE A,(T) ;MORE HAIRY CHECKS FOR DEFPROP AND DEFUN
HRRZ B,(A) ;SKIPS ON *SUCCESS*
JUMPE B,(T) ;LEAVES STUFF SPREAD OUT IN A, B, C
HRRZ C,(B)
JUMPE C,(T)
JRST 1(T)
DEFUN: PUSH P,A ;FEXPR
HLRZ AR1,(A)
CAIL AR1,QEXPR ;REMEMBER, (QEXPR, QFEXPR, QMACRO)
CAILE AR1,QMACRO ; ARE IN THAT ORDER
JRST DEF7
HRRZ A,(A) ;(DEFUN FEXPR FOO (L) EXPRESSIONS)
HRRM A,(P)
JRST DEF3
DEF7: HRRZ A,(A)
HLRZ AR1,(A)
CAIGE AR1,QEXPR
JRST DEF8
CAIG AR1,QMACRO
JRST DEF3 ;(DEFUN FOO FEXPR (L) EXPRESSIONS)
DEF8: MOVEI AR1,QEXPR ;(DEFUN FOO (L) EXPRESSIONS)
MOVE A,(P)
DEF3: JSP T,DFPR1
JRST DEFNER
MOVEI A,QLAMBDA
PUSHJ P,CONS ;CLOBBERS TT
MOVEI C,(A)
HRRZ A,(P)
JSP T,DFPR2 ;CHECK TO SEE IF ATOM
JRST DEF3A
JUMPE B,DEFNER
HRRZ AR1,(B) ;PECULIAR 3-LIST FORMAT:
HLRZ AR1,(AR1) ; (NAME EXPRNAME SUBRNAME)
JUMPE AR1,DEFNER
HRRM B,(P)
DEF3A: SKIPE VDEFUN ;THE VALUE OF DEFUN CONTROLS
JRST DEF6 ; THE EXPR-HASH HACK
DEF5: HLRZ A,@(P)
EXCH C,AR1
MOVEI B,(C)
JRST DEF1
DEF4: HRRZ A,(A) ;(DEFUN FEXPR FOO (L) EXPRESSION)
HRRM A,(P)
JRST DEF3
DEF6: HLRZ A,@(P)
MOVEI B,QXPRHSH ;EXPR-HASH
PUSHJ P,GET1 ;GET EXPR-HASH PROPERTY
JUMPE A,DEF5 ;DO DEFUN IF NONE
MOVE F,(A)
PUSH P,C
MOVEI A,(C) ;CANONICAL LAMBDA FORM
PUSHJ P,SXHASH+1 ;NCALL 1,.FUNCTION SXHASH
POP P,C
CAMN TT,F
JRST DEF9 ;AHA! HASHES MATCH! FORGET IT.
HLRZ A,@(P) ;HASHES DON'T MATCH,
MOVEI B,QXPRHSH ; SO REMOVE THE
PUSHJ P,REMPROP ; EXPR-HASH PROPERTY,
JRST DEF5 ; AND DO THE DEFUN AFTER ALL
SUBTTL TYIPEEK FUNCTION
IFE QIO,[
TYIPEEK: SKIPA D,[MAKNUM]
MOVEI D,A2TT
AOJL T,TYPKER
MOVNI TT,1 ;-1 => NO ARG, SO ANY NEXT CHAR IS TAKEN
JUMPN T,TYPK4D
TYPK4: POP P,A ;IF ARG GIVEN, THEN SCAN UNTIL SPECIFIC KIND OF CHAR IS FOUND
MOVNI TT,2 ;-2 => ARG OF T GIVEN
CAIN A,TRUTH ;ARG OF T MEANS SCAN FOR READ STARTUP CHAR
JRST TYPK4D
JSP T,FXNV1 ;IF ARG >777, THEN IT IS SYNTAX TYPE OF CHAR TO FIND
CAIGE TT,1000 ;IF ARG < 1000, THE IT IS SPECIFIC CHAR'S ASCII VALUE
JRST TYPK4D
NW% LSH TT,-9.
TLO TT,400000
TYPK4D: PUSH P,D
PUSH FXP,TT
JSP T,RSXST
TYPK4A: SKIPN A,TYIMAN
JRST TYPK5
PUSHJ P,(A)
CAIN A,203 ;PSEUDO-SPACE AT END OF STREAM
MOVEI A,↑C
CAIN A,↑C
JRST TYPK3B
PUSHJ P,TYPK7
JRST TYPK4A
MOVEM A,TMBBC
TYPX: SUB FXP,R70+1
POPJ P,
TYPK5: SKIPN TAPRED
JRST TYPK6
TYPK5A: PUSHJ P,URED
JRST TYPK3
PUSHJ P,TYPK7
JRST TYPK5A
EXCH A,C
PUSHJ P,READ3 ;BACK UP UTIBP
EXCH A,C
JRST TYPX
TYPK3: JSP A,.UEOF
TYPK3B: MOVEI A,3 ;3 IS ASCII E-O-F
JRST TYPX
;;; IFE QIO
TYPK6: SKIPE A,RDTYBF
JRST TYPK6A
TYPK6B: PUSHJ P,TYIN
PUSHJ P,TYPK7
JRST TYPK5
MOVEM A,PBFTY
JRST TYPX
TYPK6A: HLRZ A,(A)
CAIE A,203
PUSHJ P,TYPK7
JRST .+2
JRST TYPX
MOVE A,RDTYBF ;CHAR NOT ACCEPTABLE, SO CDR THE RDTYBF
HRR A,(A) ;AND TRY AGAIN
TRNN A,-1
MOVEI A,NIL
MOVEM A,RDTYBF
JUMPN A,TYPK6A
JRST TYPK6B
TYPK7: SKIPL T,(FXP) ;SKIP IF SOUGHT CHAR IS PRESENT IN A
JRST TYPK7A
NW% HLRZ TT,@RSXTB ;SIGN BIT MEANS WE ARE LOOKING FOR RCT TYPE
NW$ MOVE TT,@RSXTB
CAMN T,XC-2 ;-2 => ARG OF T, SO LOOK FOR READ STARTUP CHAR
JRST TYPK7B
CAME T,XC-1 ;-1 => NO ARG, SO ANY NEXT CHAR IS ACCEPTABLE
TDNE TT,T
AOS (P)
POPJ P,
TYPK7A: CAIN A,(T) ;OTHERWISE, LOOKING FOR SPECIFIC CHAR
AOS (P)
POPJ P,
TYPK7B:
NW% TRC TT,4040 ;IN (TYIPEEK T) MODE
NW% TRCE TT,4040
NW$ TLNE TT,(RS.MAC) ;SKIP IF NOT MACRO
NW$ TRNN TT,RS.ALT ;MACRO - SKIP IF SPLICING
JRST TYPK7D
PUSHJ FXP,SAV5M1
HRRZ A,@RSXTB
CALLF 0,(A) ;EXECUTE SPLICING MACRO, AND TRY AGAIN
PUSHJ FXP,RST5M1
POPJ P,
TYPK7D:
NW% TRNE TT,266217 ;CODES TO START OFF A READ
NW$ TDNE TT,[1266217000] ;CODES TO START OFF A READ
AOS (P)
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
TYIPEEK: ;LSUBR (0 . 3) NCALLABLE
SKIPA F,CFIX1
MOVEI F,CPOPJ
MOVEI D,QTYIPEEK
CAMGE T,XC-2
JRST WNALOSE
SKIPE T ;NO ARGS <=> ONE ARG OF NIL
AOJA T,.+2 ;ELSE DECREMENT ARG COUNT FOR INCALL
PUSH P,R70
MOVEI D,(P)
ADDI D,(T)
MOVEI AR2A,CPOPJ
EXCH AR2A,(D)
JSP D,XINCALL ;PROCESS ARGS 2 AND 3
QTYIPEEK ; (ALSO PUSHES F ONTO P)
MOVEI A,Q%TYI
HRLZM A,BFPRDP
MOVEI A,(AR2A) ;GET ARG 1 IN A
JSP T,GTRDTB ;GET READTABLE IN AR2A
JUMPN A,TYPK1 ;NIL => ACCEPT ANY CHAR
PEEK: HRRZ TT,TYIMAN ;CALL TYIMAN ONE EARLY TO
JRST -1(TT) ; SPECIFY PEEKING
TYPK1: CAIE A,TRUTH ;T => SEARCH FOR READER START
JRST TYPK3 ; CHARACTER (E.G. PAREN, MACRO)
TYPK1C: PUSHJ P,PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9A ;HIT EOF - TAKE A "SOFT" EOF, RETURN -1
MOVE T,@TTSAR(AR2A)
TLC T,4040 .SEE SYNTAX
TLCE T,4040
JRST TYPK1F
CALLF 0,(T) ;HIT A HORRIBLE SPLICING MACRO
JRST TYPK1C ;GO BACK AND TRY AGAIN
TYPK1F: TLNE T,266217 .SEE SYNTAX ;READER START CHARS
POPJ P,
TYPK1H: PUSHJ P,@TYIMAN ;CHAR NOT ACCEPTABLE - GOBBLE IT
JRST TYPK1C ;NOW GO TRY AGAIN
TYPK3: JSP T,FXNV1 ;ARG MUST BE FIXNUM
JUMPL TT,TYPK3C ;ARG BETWEEN 0 AND 777 =>
CAIG TT,777 ; SCAN FOR THAT CHARACTER;
TLOA TT,400000 ; OTHERWISE IS A SYNTAX, LSH'ED
TYPK3C: LSH TT,-11 ; LEFT BY 11, TO SERVE AS MASK
PUSH FXP,TT
TYPK4: PUSHJ P,PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9 ;SOFT EOF - GO RETURN -1 OR WHATEVER
SKIPL D,(FXP) ;SKIP IF SPECIFIC CHARACTER
JRST TYPK6
CAIN TT,(D) ;COMPARE TO ONE WE GOT
JRST POPXTJ ;SUPER WIN
TYPK5: PUSHJ P,@TYIMAN ;NOT THE ONE - GOBBLE AND RETRY
JRST TYPK4
TYPK6: HLRZ T,@TTSAR(AR2A) .SEE SYNTAX
TDNN T,D ;CHECK SYNTAX AGAINST MASK
JRST TYPK5
JRST POPXTJ
TYPK9: SUB FXP,R70+1
TYPK9A: SKIPN EOFRTN ;"SOFT" EOF. DOES NOT INVOKE
JRST M1TTPJ ; THE EOFFN, BUT WILL PICK UP
JRST EOF9 ; THE EOFVAL IF NECESSARY.
] ;END OF IFN QIO
SUBTTL VALRET AND SUSPEND FUNCTIONS
VALRET: JUMPE T,VLRT9
JSP TT,LWNACK
LA01,,QVALRET
POP P,A
PUSHJ P,VALSTR
IFN ITS,[
SETOM SAWSP
.VALUE MACOUT
SETZM SAWSP
] ;END OF IFN ITS
10$ VLRT9: EXIT 1,
10X WARN [HOW TO EXIT 1, IN TENEX]
POPJ P,
VALSTR: PUSHJ P,PNGET
SETZM MACOUT
MOVE D,[MACOUT,,MACOUT+1]
BLT D,MACOUT+LVLRTS-1
MOVSI D,-LVLRTS+1
VLRT2: HLRZ B,(A)
MOVE TT,(B)
MOVEM TT,MACOUT(D)
HRRZ A,(A)
AOBJP D,VALST0
JUMPN A,VLRT2
MOVE D,MACOUT
CAMN D,[ASCII \:kill\]
JRST .+3
CAME D,[ASCII \:KILL\]
JRST VLRT1
MOVE D,MACOUT+1
CAME D,[ASCII \ \]
CAMN D,[ASCII \
\]
JRST VLRT3
POPJ P,
VLRT1: CAMN D,[ASCII \≠_.\]
JRST VLRT3
CAME D,[ASCII \≠≠U\]
CAMN D,[ASCII \≠≠u\]
10% .LOGOUT
.ELSE XCT VLRT9
POPJ P,
VLRT3:
10$ EXIT
10X WARN [HOW TO EXIT IN TENEX]
IFN ITS,[
.LOGOUT ;TRY TO LOG OUT
JSP T,SIDDTP
.VALUE
.BREAK 16,120000 ;"SILENT KILL"
VLRT9: .LOGOUT ;TRY TO LOG OUT
.VALUE [ASCIZ \:VK \] ;OH, WELL...
POPJ P, ;IN CASE LOSER DOES $P FROM IT
SIDDTP: .SUSET [.ROPTION,,TT]
TLNN TT,10000
JRST (T)
JRST 1(T) ;SKIP IF JOB INFERIOR TO DDT
] ;END OF IFN ITS
SUSPEND: JSP TT,LWNACK
LA01,,QSUSPEND
SETZM MACOUT
JUMPE T,SUSP0
POP P,A
PUSHJ P,VALSTR
SUSP0:
IFE QIO,[
SETZ A,
MOVEI T,SUSCHS
SUSP11: JUMPE T,SUSP12
MOVE B,SUSTBL-1(T)
SKIPN (B)
SOJA T,SUSP11
HLRZS B
PUSHJ P,XCONS
SOJA T,SUSP11
SUSTBL:
QUREAD,,UTIOPD
QUWRITE,,UTOOPD
10% QPRINT,,LPTOPD
IFN MOBIOF,[
IRP X,,[IMX,OMX,IPL,DIS,NVD,BVD]Y,,[IMPX,OMPX,PLOT,DISPLAY,NVFIX,NVID]
Q!Y,,X!OPD
TERMIN
] ;END OF IFN MOBIOF
SUSCHS==.-SUSTBL
] ;END OF IFE QIO
IFN QIO,[
SETZ A,
MOVEI T,LCHNTB
SUSP11: SOJE T,SUSP12
SKIPE B,CHNTB(T)
CAMN B,V%TYI
JRST SUSP11
CAME B,V%TYO
PUSHJ P,XCONS
JRST SUSP11
] ;END OF IFN QIO
SUSP12: JUMPN A,SUSPE
IFN QIO,[
HRRZ A,V%TYI ;CLOSE THE TTYS LAST, SO THEY WONT CAUSE
PUSHJ P,$CLOSE ;SPURIOUS "CANT SUSPEND -I/O IN PROGRESS"
HRRZ A,V%TYO
PUSHJ P,$CLOSE
] ;END OF IFN QIO
SUSP1: HRROS NOQUIT
MOVEM NIL,GCNASV+1
MOVE T,[FREEAC,,GCNASV+2]
BLT T,GCNASV+2+17-FREEAC
SETOM NOPFLS
IFN ITS,[
IFN USELESS*QIO,[
MOVE T,INTMSK
TRNN T,IB<MAR>
JRST SUSP14
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70]
SUSP14:
] ;END OF IFN USELESS*QIO
.SUSET [.SSNAM,,IUSN]
MOVEI T,SUSP3
EXCH T,LISPSW
MOVEM T,GCNASV
MOVEI T,MACOUT
SKIPN (T)
MOVEI T,[ASCIZ \:≠SUSPENDED≠
\]
SETOM SAWSP
.VALUE (T)
JRST LISPGO
] ;END OF IFN ITS
IFN D10,[
HRRZ T,.JBSA"
HRL T,.JBREN"
MOVEM T,GCNASV
MOVEI T,SUSP3
HRRM T,RETHGH
OUTSTR [ASCIZ \
:$SUSPENDED$
\]
JRST KILHGH
] ;END OF IFN D10
SUSP3:
IFN ITS,[
MOVE T,GCNASV
MOVEM T,LISPSW
JSP T,SHAREP
IFE QIO,[
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
.SUSET [.SMASK,,INTMSK]
] ;END OF IFE QIO
IFN QIO,[
.SUSET [.ROPTION,,TT]
TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
.SUSET [.SOPTION,,TT]
INTON
IFN USELESS,[
MOVE T,INTMSK
TRNE T,IB<MAR>
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN USELESS
] ;END OF IFN QIO
] ;END OF IFN ITS
IFN D10,[
MOVE T,GCNASV
HRRM T,.JBSA"
HLRM T,.JBREN"
MOVEI T,630000
APRENB T,
GETPPN T,
JFCL
MOVEM T,USN
] ;END OF IFN D10
SETZM NOPFLS
MOVE NIL,GCNASV+1
MOVE T,[GCNASV+2,,FREEAC]
BLT T,17
HRRZS NOQUIT
IFN QIO,[
MOVE TT,IUSN ;IUSN WAS SET UP BY LISPGO
MOVEM TT,TTYIF2+F.SNM
MOVEM TT,TTYOF2+F.SNM
PUSH FXP,TT
PUSHJ P,OPNTTY ;*** TEMP CROCK?
JFCL
PUSH FXP,R70
MOVEI A,-1(FXP)
HRLI A,440600
] ;END OF IFN QIO
IFN ITS*<QIO-1>,[
.SUSET [.RSNAM,,TT]
MOVEM TT,IUSN
MOVEM TT,USN
PUSHJ P,TTYOPN
MOVE A,[440600,,USN]
] ;END OF IFN ITS*<QIO-1>
10% PUSHJ P,READ6C
SA% 10$ PUSHJ P,SUNAME
SA$ SETZ D,
SA$ CALLI D,400071
SA$ PUSHJ P, SUNM2
Q$ SUB FXP,R70+2
MOVEM A,SUDIR
POPJ P,
SUBTTL ARGS FUNCTION
ARGS: JSP TT,LWNACK ;LSUBR (1 . 2) - USES A,B,C,T,TT,D,R,F
LA12,,QARGS
JSP R,PDLA2(T) ;SPREAD ARGS
ARGS1: SKOTT A,SY
JRST ARGS0 ;FIRST ARG MUST BE SYMBOL
HLRZ F,(A)
ARGS1A: AOJL T,ARGS3 ;TWO ARGS
HLRZ R,1(F) ;JUST WANT TO GET PRESENT ARGS PROP
ARGSCU: JUMPE R,FALSE ;ARGS CONS-UP
IDIVI R,1000
SKIPN B,F
JRST ARGSC1
MOVEI TT,-1(F)
JSP T,FIX1A
MOVEI B,(A)
ARGSC1: SKIPN A,R
JRST CONS
MOVEI TT,(R)
CAIE TT,777
SUBI TT,1
JSP T,FIX1A
JRST CONS
ARGS3: JUMPE A,CPOPJ
JUMPN B,ARGS5
HLRZ R,1(F) ;JUST WANT TO FLUSH ARGS PROP
JUMPE R,FALSE
SETZ R,
PUSH P,A
JSP D,ARGCLB
SUB P,R70+1
JRST TRUE
ARGS5: PUSH P,A
SETZB TT,R
HLRZ C,(B) ;MUMBLE MUMBLE - MUST FIGURE
JUMPE C,ARGS6 ; OUT WHATEVER WE WERE HANDED
JSP T,FXNV3
CAIE R,777
ADDI R,1
LSH R,11
ARGS6: HRRZ A,(B)
JSP T,FXNV1
CAIE TT,777
ADDI TT,1
ADDI R,(TT)
HLRZ TT,1(F) ;LOOK AT ARGS PROP ALREADY THERE
CAIN TT,(R) ;IF ALREADY WHAT WE WANT, JUST EXIT,
JRST POPAJ ; THEREBY AVOIDING A PURE PAGE TRAP
MOVEI D,POPAJ ;FAKE OUT A JSP D,
ARGCLB: MOVEI B,(F) ;CLOBBER IN AN ARGS PROPERTY
ARGCL3:
PURTRAP ARGCL7,B, HRLM R,1(B) ;MAY HAVE TO FUSS ABOUT PURE PAGE TRAP
JRST (D)
ARGS0: MOVEI F,$$$NIL
JUMPE A,ARGS1A
WTA [ NON-SYMBOL - ARGS!]
JRST ARGS1
SUBTTL EVALFRAME FUNCTION, GTPDLP, AND FRETURN
EVALFRAME:
SKIPA R,[GTPDLP] ;THIS ENTRY CAUSES INTERPRETATION OF ARG AS PDLPOINTER
FRM2A: MOVEI R,GTPDL2 ;THIS ENTRY, TO ALLOW CONTINUING FROM WHERE D CURRENTLY IS
JSP R,(R)
$EVALFRAME ;GET EVALFRAME OR APPLYFRAME JUST PRIOR TO
$APPLYFRAME ; POINT ON PDL MARKED BY ARG
JRST FALSE
FRM3: SUB D,R70+1 ;DEFINE A FRAME POINTER TO BE JUST BELOW THE EVALFRAME MARKER
HRRZ TT,(D)
JUMPN F,FRM3A ;F IS INDEX OF WHICH KIND OF FRAME
MOVEI T,(TT)
LSH T,-SEGLOG
SKIPL ST(T)
JRST FRM4A
HLRZ TT,(TT)
FRM3A: CAIN TT,QEVALFRAME ;DONT ALLOW THE CALL TO EVALFRAME
JRST FRM2B ; ITSELF TO BE OUTPUT
FRM4A: PUSH P,(D)
FRM4: ;ERRFRAME COMES HERE
HLRO TT,(D) ;ONE LEFT HALF'S AS GOOD AS ANOTHER...
JSP T,FIX1A ;MAKE UP PREVIOUS SPECIAL PDL POINTER
PUSHJ P,ACONS
EXCH B,(P)
MOVE TT,1(D)
CAME TT,[$APPLYFRAME]
JRST FRM8
PUSH P,A
PUSH P,B
MOVE T,-2(D) .SEE $APPLYFRAME ;BECAUSE THERE IS A DISCUSSION
JUMPL T,FRM5 ; OF THE FRAME FORMAT THERE
MOVEI A,(T)
TLCN T,-1 ;THINK ABOUT THIS WHEN YOU LOOK!
JRST FRM7
HLRS T ;SUBTLE WAY TO GET NEGATION
ADDI T,(D)
FRM5: SETZ A,
FRM5A: HRRZ B,(T)
PUSHJ P,XCONS
AOBJN T,FRM5A
PUSHJ P,NREVERSE
FRM7: PUSHJ P,ACONS
POP P,B
PUSHJ P,XCONS
MOVEI B,(A)
POP P,A
FRM8: PUSHJ P,XCONS
MOVE B,A ;OUTPUT 4-LIST: "EVAL" OR "APPLY" OR "ERR" [A SYMBOL]
HRROI TT,(D) ; FRAME (REGPDL) POINTER [A FIXNUM]
JSP T,FIX1A ; <FORM> [EVAL] OR (<FN> <ARGS>) [APPLY]
PUSHJ P,CONS ; OR <MSG-FORM> [ERR]
MOVE TT,1(D) ; ALIST (SPECPDL) POINTER [A FIXNUM]
MOVEI B,QOEVAL
CAMN TT,[$APPLYFRAME]
MOVEI B,QAPPLY
CAMN TT,[$ERRFRAME]
MOVEI B,QERR
PUSHJ P,XCONS
JRST POPBJ
FRM2B: TLNE R,1
ADD D,R70+2 ;WHEN SEARCHING FORWARD, SKIP OVER CALL
JRST FRM2A ;TO EVALFRAME
GTPDLP: ;CALLED BY JSP R,GTPDLP; RETURNS PDL PTR IN D
MOVEI D,(P)
JUMPE A,GTPDL2 ;ARG=NIL => START SEARCH FROM CURRENT PDL POS
JSP T,FXNV1 ;NOTE: EVALFRAME LOOKS AT BIT 3.1 OF R
JUMPL TT,GTPDL5 ;BIT 3.1 OF R = 0 WHEN SEARCHING BACK THE PDL
TLO R,1 ;BIT 3.1 OF R = 1 WHEN SEARCHING FORWARD
MOVNS TT ;WANT TO SKIP OVER THE FRAME MARKER WHEN
SKIPN TT ; SEARCHING FORWARD (SINCE A PDLPOINTER WILL
SKIPA TT,C2 ; BE POINTING TO ONE BELOW A FRAME MARKER)
ADD TT,R70+2
GTPDL5: TLZ TT,-1
HRRZ T,C2
CAIGE TT,(T)
JRST GTPDL1
MOVEI T,(P)
SUBI T,(TT)
JUMPLE T,GTPDL1
MOVEI T,(TT)
CAIL T,(P)
MOVE TT,P
HRROI D,(TT)
GTPDL2: MOVE TT,(R) ;KEY ON WHICH TO SEARCH
JUMPE TT,2(R) ;MATCH 0 => NO SEARCH, JUST GIVE OUT PDL PTR
MOVE F,1(R) ;WELL, IT'S POSSIBLE TO SEARCH FOR TWO THINGS
TLNE R,1
JRST GTPDL4
HRRZ T,C2
GTPDL3: CAIL T,(D) ;A BACK SEARCH
JRST 2(R) ;SEARCHED-AND-FAILED EXIT
CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
SOJA D,GTPDL3
GTPDL4: MOVEI T,(P)
GTP4A: CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
CAIG T,(D)
JRST 2(R) ;FAILURE
AOJA D,GTP4A
GTPX0: TDZA F,F
GTPX1: MOVEI F,1
JRST 3(R)
FRETURN: MOVE C,B
JSP R,GTPDLP
0
JFCL
MOVEI F,(D)
MOVE TT,[$EVALFRAME]
CAMN TT,1(F)
JRST FRETR1
MOVE TT,[$APPLYFRAME]
CAME TT,1(F)
JRST FRERR
FRETR1: MOVEI D,(F)
SUBI D,(P)
HRLI D,(D)
HRRI D,(F)
MOVE TT,[$UIFRAME]
CAME TT,(D) ;SEARCH FOR A USER INTERRUPT FRAME
AOBJN D,.-1
CAMN TT,(D)
JSP TT,UIBRK
FRP1: SKIPE T,PA4 ;BREAK UP A DOMINEERING PROG
CAIL F,(T) ;[WHICH BREAKS UP INTERIOR ERRSETS AND CATCHES]
JRST FRP2
MOVEI TT,FRP1-1 ;FAKE OUT RETURN BY INSERTING A RETURN-ADDRESS
MOVEM TT,-LPRP+1(T) ;OF FRP1 ON THE PDL
JRST RETURN
FRP2: SKIPN B,ERRTN ;BREAK UP A DOMINEERING ERRSET OR CATCH
SKIPE B,CATRTN
FRP2A: CAIL F,(B)
JRST FRP3
MOVEI TT,FRP1
JRST BKRST0
FRP3: SKIPN B,EOFRTN ;BREAK OUT OF ANY E-O-F SET READS
JRST FRP3QA
CAIGE F,(B)
JRST FRP2A
FRP3QA: MOVE A,C
HRROI P,1(F) ;SEE ABOVE FOR WHY LH IS -1
HLRO FLP,-2(P)
HRRO FXP,-2(P)
HLRZ TT,-1(P)
JRST UBD ;UNBIND TO MARKED POINT, AND POP FRAME
SUBTTL GETCHAR, GETCHARN, AND SUBLIS
$GETCHARN: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE
SKIPA F,[ZPOPJ,,CPOPJ]
GETCHAR: MOVE F,[FALSE,,RDCH2] ;SUBR 2
SKIPE V.RSET
JRST GETCH8
MOVE D,(B)
PUSHJ P,PNGT0
GETCH1: SOJL D,(F)
IDIVI D,5 ;(Q,R) QUOTIENT,REMAINDER IN D,R
SOJL D,GETCH3
GETCH2: HRRZ A,(A) ;CDR BY Q WORDS
SOJGE D,GETCH2 ;RECALL THAT (CDR NIL) = NIL
JUMPE A,GETCH4
GETCH3: HLRZ A,(A)
LDB TT,GTCTB(R)
JUMPN TT,(F)
GETCH4: MOVS F,F
JRST (F)
GETCH8: JSP T,FXNV2
PUSHJ P,PNGET
JRST GETCH1
GTCTB: 350700,,(A)
260700,,(A)
170700,,(A)
100700,,(A)
010700,,(A)
SUBLIS: PUSH P,A ;USES ONLY A,B,T,TT,D,R
PUSH P,B
MOVE D,A
HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE
SUBL1: JUMPE D,SUBL2
HLRZ T,(D) ;A SUBSTITUTION LIST IS LIKE
HLRZ B,(T) ;((U1 . S1) (U2 . S2) . . .)
SKOTT B,SY
JRST SUBLOSE
SUBL1B: HRRZ A,(B) ;SEXPRESSION S IS SUBSTITUTED FOR ATOM U
HLRZ A,(A)
CAIN A,QSUBLIS
JRST SUBL1A
HRRZ A,(T)
MOVEM B,T
HRRZ B,(B)
PUSHJ P,CONS
MOVEI B,QSUBLIS ;PUT "SUBLIS" PROPERTY ONTO THOSE ATOMS U IN THE
PUSHJ P,XCONS ;SUBSTITUTION LIST ((U1 . V1) . . . (UN . VN))
HRRM A,(T)
SUBL1A: HRRZ D,(D)
MOVE T,INTFLG
AOJGE T,SUBL1 ;0=> NO INT, -1=> USER INT, -2,-3=> QUIT
MOVE R,D
JRST SUBL3Q
SUBLOSE: JUMPE B,SUBL3Z
MOVEI A,(B)
MOVEI R,(D)
MOVEI T,[LER3 [SIXBIT \NON-ATOMIC ITEM - SUBLIS!\]]
MOVEM T,-1(P)
SUBL3Q: SUB P,R70+1
JRST SUBL3A
SUBL3Z: MOVEI B,NILPROPS
JRST SUBL1B
SUBL2: POP P,A
PUSHJ P,SBL1
JFCL
MOVEI R,0 ;REMOVE ALL "SUBLIS" PROPERTIES
SUBL3A: MOVE TT,(P)
SUBL3: CAIN R,(TT) ;REMOVE "SUBLIS" PROPERTY
JRST SUBL4
HLRZ T,(TT)
HLRZ T,(T)
JUMPN T,.+2
MOVEI T,NILPROPS
HRRZ B,(T)
MOVE B,(B)
HLRZ D,B
HRRZ B,(B)
CAIN D,QSUBLIS
HRRM B,(T)
HRRZ TT,(TT)
JRST SUBL3
SUBL4: SUB P,R70+1
JRST CZECHI
SBL1: SKOTT A,LS ;TRACE THROUGH STRUCTURE IN (A) SUBSTITUTING
JRST SBL2 ;(GET 'U 'SUBLIS) FOR U WHEREVER IT IS NON-NIL
PUSH P,A
HLRZ A,(A)
PUSHJ P,SBL1
JRST SBL4
EXCH A,(P)
HRRZ A,(A)
PUSHJ P,SBL1
JFCL
HRRZ B,(P)
SBL5: SUB P,R70+1
PUSHJ P,XCONS
JRST POPJ1
SBL4: HRRZ A,@(P)
PUSHJ P,SBL1
JRST POPAJ
HLRZ B,@(P)
JRST SBL5
SBL2: TLNN TT,SY
JRST SBL2B
HRRZ B,(A)
SBL2A: HLRZ T,(B)
CAIE T,QSUBLIS
POPJ P,
HRRZ A,(B)
HLRZ A,(A)
JRST POPJ1
SBL2B: JUMPN A,CPOPJ
HRRZ B,NILPROPS
JRST SBL2A
SUBTTL SAMEPNAMEP AND ALPHALESSP
SAMEPNAMEP: TDZA D,D ;USES ONLY A,B,T,TT,D
ALPHALESSP: MOVEI D,TRUTH ;MUST PRESERVE C,AR1,AR2A,R,F (SEE SORT)
PUSH P,B
PUSHJ P,PNGET
EXCH A,(P)
PUSHJ P,PNGET
POP P,B ;FROM NOW ON, A HAS PNAME OF 2ND ARG, B OF 1ST!!!
JRST ALPLP1
ALPL3: HRRZ A,(A)
HRRZ B,(B)
ALPLP1: JUMPE B,ALPL2
JUMPE A,FALSE ;ON SAMEPN, LOSE IF 2ND ARG RUNS OUT BEFORE 1ST
HLRZ T,(A) ;ON ALPHAL, LOSE IF 2ND ARG IS SHORTER THAN 1ST
MOVE T,(T)
HLRZ TT,(B) ;FOR SAMEPN, WILL RETURN NIL IF TWO ARE UNEQUAL IN SOME PLACE
CAMN T,(TT) ;NO INFO IF CORRESPONDING PLACES ARE EQUAL
JRST ALPL3
JUMPE D,FALSE ;BUT NOT EQUAL IN SAMENAMEP MEANS LOSE
MOVE TT,(TT) ;MUST DO SOME HAIR FOR THE ALPHALESSP
LSHC T,-1 ; COMPARE TO WIN, SINCE PNAME WORDS ARE
CAMG T,TT ; LOGICAL DATA, NOT ARITHMETIC
JRST FALSE ;2ND ARG STRICTLY LESS THAN FIRST
JRST TRUE ;2ND ARG STRICTLY GREATER THAN FIRST
ALPL2: EXCH A,D
JUMPE D,NOT ;IF ALPHAL, WIN WHEN A NON-NUL [FOR 1ST ARG IS PROPER SUBSTRING OF 2ND]
POPJ P, ;IF SAMEPN, WIN WHEN A NUL [FOR CORRESPONDENTS HAVE BEEN EQUAL ALL ALONG]
SYSP: MOVEI B,TRUTH ;SUBR 1 - DETERMINE WHETHER SYMBOL HAS
SYSP3:
10% CAIGE A,BEGFUN ; A "SYSTEM" SUBR PROPERTY
10$ CAIL A,ENDFUN
JRST FALSE
10% CAIG A,ENDFUN
10$ CAIL A,BEGFUN
JRST BRETJ
CAIGE A,BSYSAR ; ... OR MAYBE A SYSTEM ARRAY PROPERTY
JRST SYSP6
CAIGE A,ESYSAR
JRST BRETJ ;RETURNS T FOR SUBR/SAR POINTERS
CAIE B,QAUTOLOAD
JRST SYSP6
CAIL A,BSYSAP
CAIL A,ESYSAP
JRST FALSE
JRST BRETJ
SYSP6: JSP T,SPATOM ;RETURNS FALSE FOR NON-SYMBOLS
JRST FALSE
MOVEI B,ASBRL
PUSHJ P,GETL1
JUMPE A,CPOPJ ;RETURNS FALSE FOR SYMBOLS WITH NO FN PROPS
HLRZ B,(A) ;RETURNS NAME OF PROPERTY OF ONE IS FOUND,
JSP T,%CADR
JRST SYSP3 ; AND THE PROPERTY VALUE PASSES THE SYSP TEST
GCTWA: JUMPE A,GCTWI
HLRZ A,(A)
PUSHJ P,NOTNOT
MOVEM A,VGCTWA
JRST GCTWX
GCTWI: SETOM IRMVF
GCTWX: MOVEI A,IN0
SKIPGE IRMVF
ADDI A,1
SKIPE VGCTWA
ADDI A,10
POPJ P,
SUBTTL COPYSYMBOL FUNCTION
COPYSYMBOL: JUMPE A,CPOPJ
JSP T,SPATOM
JSP T,PNGE
JUMPN B,CPSY0
CPSY: PUSHJ P,PNGT0
JRST SYCONS
CPSY0: PUSH P,A
PUSHJ P,CPSY
EXCH A,(P)
PUSH P,A
HRRZ A,(A)
JUMPE A,S1PAJ
MOVEI B,NIL
PUSHJ FXP,SAV5M3
PUSHJ P,.APPEND
PUSHJ FXP,RST5M3
HRRM A,@-1(P)
HLRZ A,@(P)
HLRZ T,1(A) ;ARGS PROPERTY
JUMPE T,.+3
HLRZ TT,@-1(P)
HRLM T,1(TT)
HRRZ A,@(A)
CAIN A,QUNBOUND
JRST S1PAJ
EXCH AR1,-1(P)
JSP T,.SET
EXCH AR1,-1(P)
JRST S1PAJ
SUBTTL SETSYNTAX AND OTHER READER SYNTAX FUNCTIONS
;ARGS ARE CHAR (AS NUMBER OR ATOM), SYNTAX-CODE, MACRO-OR-TRANSLATION
SETSYNTAX: SETZ AR1, ;SUBR 3
MOVEI AR2A,(B)
JSP T,SPATOM
JRST RSSYN1
JSP T,CHNV1
JSP T,FIX1A
RSSYN1: CAIN AR2A,QMACRO
JRST RSSYN2
CAIE AR2A,QSPLICING
JRST RSSYN3
MOVEI AR1,[QSPLICING,,NIL]
RSSYN2: MOVE B,A
PUSH P,CTRUE
PUSH P,AR1
JRST SSMC43
RSSYN3: MOVSI AR1,40000 ;WAY TO FAKE OUT SSYN0
MOVEI B,(A)
JUMPE C,RSSYN5 ;SKIP IF NO CHTRAN STUFF
PUSHJ P,RSSYN4
HRRZM A,(FXP)
IFN NSTAT,[
MOVEI A,(B) ;LOSING RETROFIT
MOVEI B,(C)
] ;END OF IFN NSTAT
PUSHJ P,SSCHTRAN
SUB FXP,R70+1
RSSYN5: JUMPE AR2A,TRUE ;XIT IF NO SYNTAX STUFF
CAIE AR2A,QSINGLE
JRST RSSYN7
NW% PUSH FXP,[600500]
NW$ PUSH FXP,[RS.SCS]
MOVEI C,(FXP)
JRST RSSYN8
RSSYN7: MOVE C,AR2A
PUSHJ P,RSSYN4
HLRZS (FXP)
RSSYN8:
IFN NSTAT,[
MOVEI A,(B) ;LOSING RETROFIT
MOVEI B,(C)
] ;END OF IFN NSTAT
PUSHJ P,SSSYNTAX
SUB FXP,R70+1
CTRUE: JRST TRUE
RSSYN4: PUSH FXP,R70
MOVEI A,(C)
JSP T,SPATOM
POPJ P,
MOVEI C,(B) ;SAVE B
JSP T,CHNV1
MOVEI A,(TT)
MOVEI B,(C) ;RESTORE B
MOVEI C,(FXP) ;SET C TO BE FIXNUM ON TOP OF PDL
JSP T,RSXST
MOVE TT,@RSXTB
MOVEM TT,(FXP)
POPJ P,
SSCHTRAN:
NW% SKIPA F,[HRRM R,(TT)]
NW$ SKIPA F,[DPB R,[001100+TT,,]]
SSSYNTAX:
NW% MOVSI F,(HRLM R,(TT))
NW$ MOVE F,[LDB R,[113300+TT,,]]
PUSH P,[SPROG3]
MOVSI AR1,40000 ;LOSING CROCK
SSSYN1:
IFN NSTAT, MOVEI C,(B) ;LOSING CROCK
IFN NSTAT, MOVEI B,(A)
PUSHJ P,GRCTI ;GET INDEX FOR RCT INTO D
TLNE AR1,40000 ;40000 BIT SAYS EVAL 3RD ARG
JSP T,FXNV3
JSP T,SMCR2 ;LOCK AND SETUP RCT ARRAY PTR INTO TT
ADDI TT,(D)
XCT F ;MAY SKIP (FOR (STATUS CHTRAN))
UNLKPOPJ ;MUST BE ONLY ONE INSTRUCTION.
NW% TLNE TT,4000 ;SKIP UNLESS MACRO CHAR
NW$ TLNE TT,(RS.MAC);SKIP UNLESS MACRO CHAR
MOVEI TT,(D) ;USE CHARACTER AS ITS OWN CHTRAN
TLZ TT,-1
UNLKPOPJ
GRCTI: JSP T,FXNV2 ;GET READTABLE INDEX
CAIGE D,NASCII
JUMPGE D,CPOPJ
JRST GRCTIE
SMACRO:
IFN NSTAT, MOVEI B,(A)
PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
SMCR1: MOVEI A,NIL
MOVE C,(TT)
UNLOCKI
NW% TLNN C,4000
NW$ TLNN C,(RS.MAC)
POPJ P, ;EXIT WITH NIL IF NO MACRO CHAR
NW% TLNE C,40
NW$ TRNE C,RS.ALT
MOVEI A,QSPLICING ;SPLICING TYPE
PUSHJ P,NCONS
NW% MOVEI B,(C)
NW$ PUSH P, A
NW$ PUSHJ P, GETMAC
NW$ HRRZ B, (A) ;CDR OF ASSQ IS FUNCTION
NW$ POP P, A
PUSHJ P,XCONS
POPJ P,
IFN NEWRD,[
;;;ROUTINE TO GET MACRO ENTRY. CHAR IN D.
;;; CLOBBERS A, B, TT, RETURNS (CHAR . FCN) IN A
;;; RSXST MUST HAVE BEEN DONE
GETMAC: MOVEI A, 206 ;GET FCN LIST FROM READTABLE
HRRZ B, @RSXTB ;..
MOVE A, D ;CHARACTER
PUSHJ P, ASSQ
JUMPE A, [LERR [SIXBIT/MACRO CHARACTER VANISHED#!!/]]
POPJ P,
] ;END OF IFN NEWRD
SSMACRO:
IFN NSTAT,[
CAME T,XC-3 ;CROCK TO GET NSTAT UP FAST
PUSH P,R70
POP P,A
POP P,C
POP P,B
SKIPE A
PUSHJ P,ACONS
PUSH P,A
] ;END OF IFN NSTAT
SSMC43: PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
HRRZM TT,RM4
JUMPE C,SSM1
NW% HRLI C,404500
NW$ MOVE C,[RS.CMS]
SKIPE A,(P)
JRST SSM3
SSM4:
EXCH C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCREL ;CLOBBERS C
IFN NEWRD,[
TLNN C,(RS.MAC)
JRST SSM4AA
PUSHJ P, GETMAC
;REMOVE PREVIOUS MACRO FUNCTION FROM ASSQ LIST.
;**** (SETQ MAC-LIST (DELQ A MAC-LIST)) ****
SSM4AA: ;AND NO GCREL CRUFT NECC.
]
MOVE C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCPRO
NW% HRRM A,@RM4
NW$ DPB D, [001100,,@RM4] ;MACROS MUST HAVE SELF AS CHTRAN
NW$ MOVE B, D ;***SURELY THIS COULD BE A LOT LESS KLUDGEY***
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVE A, @RSXTB
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVEM B, @RSXTB
SUB P,R70+1
MOVE TT,RM4
JRST SMCR1
SSM3: MOVEI AR1,(B)
HLRZ A,(A)
JSP T,CHNV1
CAIN TT,"S ;SPLICINGP
NW% TLO C,40
NW$ TRO C,RS.ALT
MOVEI B,(AR1)
JRST SSM4
SMCR2: LOCKI
JRST RSXST
SSM1: HRLI D,2
MOVE C,RCT0(D)
NW% TLNE C,4000 ;WAS IT ORIGINALLY A MACRO CHAR?
NW$ TLNE C,(RS.MAC)
MOVE C,D
JRST SSM4
SSGCREL: TDZA D,D ;MUST HAVE USER INTERRUPTS OFF
SSGCPRO: MOVEI D,1
JSP T,SPATOM
JRST .+2
POPJ P,
SAVE A B
HRRZ R,(B)
CAIGE R,200
HRL R,VREADTABLE
HRRI R,IN0(R)
MOVE B,PROLIS
JUMPE D,SSGRL1
PUSHJ P,ASSOC
JUMPE A,SSPROQ
HLRZ A,(A)
MOVEM A,-1(P)
SSPROQ: MOVE B,R
PUSHJ P,CONS1
MOVE B,-1(P)
PUSHJ P,XCONS
MOVE B,PROLIS
PUSHJ P,CONS
MOVEM A,PROLIS
MOVE A,-1(P)
SSPROX: POP P,B
JRST POP1J
SSGRL2: MOVE A,-1(P)
SSGRL1: PUSHJ P,ASSQ
JUMPE A,SSPROX
HRRZ B,(B)
HRRZ T,(A)
CAME R,(T) ;COMPARES READTABLE AND NUMBER
JRST SSGRL2
MOVE B,PROLIS
PUSHJ P,.DELETE
MOVEM A,PROLIS
MOVEI A,0
JRST SSPROX
IFE QIO,[
SUBTTL IOC AND IOG FUNCTIONS
IOC: JUMPE A,CPOPJ ;FSUBR
HRROI R,IOC1
PUSHJ P,PRINTA
JRST TRUE
IOC1: CAIL A,"@ ;100
CAILE A,"↑ ;136
POPJ P,
SETZM IPCLOK
PUSHJ P,UINTPU
ANDCMI A,100
JSR CNTROL
IOC2: JRST UINTEX
IOG: PUSHJ P,IOGBND ;FSUBR
HRRZ B,(A)
HLRZ A,(A)
PUSH P,B
SKIPE A
PUSHJ P,IOC
POP P,B
PUSHJ P,IPROGN
JRST UNBIND
] ;END OF IFE QIO
AUTOLOAD: HRL A,T
PUSHJ P,ACONS
MOVSS (A)
PUSH P,A ;FOR GC PROTECTION
IFE QIO,[
HRLI A,18. ;INTERRUPT NO. FOR AUTOLOAD FUN
MOVSS A
PUSHJ P,UINT
] ;END OF IFE QIO
IFN QIO,[
PUSH FXP,D
MOVSI D,(A)
HRRI D,1000 ;AUTOLOAD USER INTERRUPT
PUSHJ P,UINT
POP FXP,D
] ;END OF IFN QIO
JRST POP1J
IFN ITS,[
SUBTTL SYSCALL FUNCTION
SYSCALL: MOVEI D,QSYSCALL
CAML T,[-10.]
CAMLE T,XC-2
JRST WNALOSE
MOVEI D,2(P)
ADD D,T ;D POINTS TO ARG WITH .CALL NAME IN IT
MOVNM T,SYSCL8 ;#ARGS+2
JSP T,0PUSH+2(T) ;PUSH SLOTS FOR COPYING FIXNUM ARGS
SCSL0: MOVE A,-1(D)
JSP T,FXNV1 ;<CONTROL-BITS>,,<NUMBER-OF-OUTPUTS-DESIRED>
HLL D,TT
HRRZS TT
CAILE TT,20
JRST SCSTMA
HRLM TT,SYSCL8 ;#ANSWERS,,#ARGS+2
MOVE A,(D)
PUSH FXP,D
PUSHJ P,SIXMAK
MOVSI D,(SETZ)
EXCH D,(FXP) ;THE SETZ GETS PUT OUT HERE
MOVEI R,-1(FXP)
MOVEI F,(FXP)
PUSH FXP,TT ;THE SIXBIT FOR THE NAME OF THE .CALL
HLRZ T,D
TLZ D,-1
TLO T,5000 ;THE CONTROL BITS ARG
JRST SCSL1A
SCSL1: HRRZ T,(D)
SKOTT T,FX
JRST SCSL1A
MOVE TT,(T)
MOVEM TT,(R)
MOVEI T,(R)
SUBI R,1
SCSL1A: PUSH FXP,T
IFN QIO,[
MOVEI AR1,(T)
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
MOVE T,R ;DOUBLE FOO - JONL!!
JSP TT,XFILEP
JRST SCSL6
MOVE TT,[@TTSAR]
ADDM TT,(FXP)
SCSL6: MOVE R,T
] ;END OF IFN QIO
CAIGE D,(P) ;LOOP TO INSTALL REMAINING INPUT ARGS
AOJA D,SCSL1
HLRZ D,SYSCL8
SOJL D,SCSL4
MOVEI T,1(FXP)
HRLI T,2000
SCSL3: PUSH FXP,T ;LOOP TO INSTALL ANSWER REQUESTS
ADDI T,1
SOJGE D,SCSL3
SCSL4: MOVSI T,(SETZ) ;FINAL SETZ SIGNALS END OF PARAMETERS
IORM T,(FXP) ;[THERE WILL ALWAYS BE AT LEAST ONE, I.E. THE CONTROL]
Q$ MOVEI TT,F.CHAN
.CALL (F)
JRST SCSFAI
SETZB A,B
HLRZ D,SYSCL8
SCSL5: JUMPE D,SCSXIT ;LOOP TO LISTIFY UP NUMERIC ANSWERS
POP FXP,TT
PUSHJ P,CONSFX
SOJA D,SCSL5
SCSTMA: MOVEI TT,15
JRST SCSXT1
SCSFAI: .SUSET [.RBCHN,,R]
.CALL SCSTAT
.VALUE
LDB TT,[220600,,D]
MOVE D,SYSCL8
HLRS D
SUB FXP,D ;TAKE OFF THE SLOTS FOR ANSWERS
JSP T,FXCONS ;LISP NUMBER FOR ERROR CODE
SCSXIT: MOVE D,SYSCL8 ;SYSCL8 HAS 2+#ARGS
ADDI D,-1(D) ;PUSHED WAS 3+2*#ARGS
HRLS D ; WHICH IS 2*SYSCL8-1
SUB FXP,D
SCSXT1: MOVE D,SYSCL8
HRLS D
SUB P,D ;STRAIGHTEN UP P
POPJ P,
SCSTAT: SETZ
SIXBIT \STATUS\ ;GET CHANNEL STATUS
,,R ;CHANNEL #
402000,,D ;STATUS WORD
.SEE IOCERR
.SEE CHNI1
] ;END OF IFN ITS
;;@ STATUS 93 HAIRY STATUS FUNCTIONS
SUBTTL INTERPRETER FOR STATUS SERIES
IFE NSTAT,[
SSTATUS: SKIPA F,[QSSTATUS]
STATUS: MOVEI F,QSTATUS
JUMPE A,STERR
MOVEI AR1,(A)
PUSH P,A
SSSSLU: JSP R,SPNLU ;LOOK UP NAME IN ASCII TABLE, RET INDEX IN A
MOVSI A,-LSTBA
STAT5: CAMN TT,STBA(A)
JRST STAT6
AOBJN A,STAT5
SSTSER: TDZA A,A
SSSSST: MOVEI A,TRUTH
JUMPL F,POP1J
MOVEI A,(AR1)
CAIE F,QSSTATUS
SKIPA T,[[SIXBIT \UNKNOWN REQUEST - STATUS!\]]
MOVEI T,[SIXBIT \UNKNOWN REQUEST - SSTATUS!\]
MOVEI B,(F)
PUSHJ P,XCONS
SUB P,R70+1
%FAC (T)
STAT6: MOVEI D,(F)
CAIE D,QSSTATUS
JRST STAT3
TLZ A,-1
CAIL A,LSST
JRST SSTSER
SKIPA A,STBSS(A)
STAT3: MOVE A,STBS(A)
JUMPL F,SSSSST
EXCH A,AR1
HLL D,AR1
LSH D,13
ASH D,-12
HRRI D,(F)
TLO D,1
MOVEM D,SWNACK
MOVEI TT,SWNACK
JRST FWNACK
STAT1: TLNE AR1,200000
PUSHJ P,STEV ;EVAL 2ND ARG
TLNE AR1,100000
PUSHJ P,SG1C ;GET PNAME 2ND ARG, 1 CHARA
TLNE AR1,40000
PUSHJ P,STEV3 ;EVAL 3RD ARG
TLNE AR1,20000
POP P,A ;NOT SAVE ARG LIST
TLNE AR1,10000
JRST SCLG ;SIMPLY GET CELL & EXIT
TLNE AR1,4000
JRST SCLST ;SIMPLY STORE T OR NIL IN CELL & EXIT
TLNE AR1,1000
JRST SSSBX ;STORE VALUE OF SECOND ARG IN CELL
TLNN AR1,2000
JRST (AR1) ;JRST TO SPECIALIZED ROUTINE
HRRZ TT,(AR1)
JRST FIX1 ;GET A NUMBER
SSSBX: MOVEM B,(AR1)
JRST SPROG2
;;; IFE NSTAT
SG1C: HLRZ A,@-1(P) ;GET ONE ASCII CHARACTER VALUE
JSP T,SPATOM
JRST STEV ;NOT PNAME-TYPE ATOM => EVAL, GET BACK NUMBER
PUSH P,-1(P)
JSP R,SPNLU3 ;PNAME-TYPE ATOM => GET FIRST CHAR OF PNAME
POP P,-2(P)
LSH TT,-29.
JSP T,FIX1A
MOVEI B,(A)
POPJ P,
SPNLU: HLRZ A,@(P) ;GET ASCII OF FIRST WORD OF PNAME FROM
SPNLU3: PUSHJ P,PNGET ;NEXT ARG, PUT IN TT
HLRZ TT,(A)
MOVE TT,(TT)
HRRZ A,@(P)
MOVEM A,(P)
JRST (R)
STEV: PUSH P,AR1
HLRZ A,@-2(P) ;EVAL 2ND ARG, E.G.
PUSHJ P,EVAL ;(STATUS SYNTAX 105)
MOVE B,A
STEV2: HRRZ A,@-2(P)
MOVEM A,-2(P)
POP P,AR1
POPJ P,
STEV3: PUSH P,AR1
PUSH P,B
HLRZ A,@-3(P)
PUSHJ P,EVAL
POP P,B
MOVE C,A
JRST STEV2
SCLG: HRRZ A,(AR1) ;SIMPLY GET A CELL AND EXIT
POPJ P,
SCLST: MOVE A,B ;SIMPLY STORE T OR NIL AND EXIT
PUSHJ P,NOTNOT
HRRM A,(AR1)
POPJ P,
] ;END OF IFE NSTAT
IFN NSTAT,[
STATER: MOVEI B,(AR2A)
MOVEI A,(F)
PUSHJ P,CONS
FAC [ILLEGAL REQUEST!]
SSTATUS: SKIPA F,CQSSTATUS ;FEXPR
STATUS: MOVEI F,QSTATUS ;FEXPR
MOVEI AR2A,(A)
JUMPE A,STATER
HLRZ A,(A) ;FIRST ARG IS FUNCTION NAME
PUSHJ P,STLOOK ;LOOK IT UP IN ASCII TABLE
JRST STATER
CAIE F,QSTATUS ;STATUS OR SSTATUS?
ADDI R,STBSS-STBS
ADDI R,STBS
MOVE D,(R) ;GET TABLE ENTRY
LSH D,13
ASH D,-12
TLO D,1
HRRI D,(F)
MOVEM D,SWNACK ;HACK FOR ARGS CHECKING
MOVEI A,(AR2A)
MOVEI TT,SWNACK
JRST FWNACK
;RETURN HERE FROM FWNACK IF ARGS OKAY
STAT1: HRRZ A,(A) ;CDR ARGS LIST
HRLI R,410200
PUSH FXP,R ;BYTE POINTER TO ARGS DESCRIPTORS
PUSH FXP,R70 ;COUNTER FOR ARGS
STAT2: JUMPE A,STAT6 ;JUMP IF NO MORE ARGS
PUSH P,A
HLRZ A,(A) ;ELSE GET NEXT ARG
ILDB T,-1(FXP) ;GET ARG DESCRIPTOR
JRST .+1(T)
JRST STAT6 ;0 END OF ARGS
JRST STAT3 ;1 QUOTED ARG
JRST STAT8 ;2 QUOTED LIST OF REST
PUSHJ P,EVAL ;3 EVALUATED ARG
STAT3: EXCH A,(P) ;LEAVE ARG ON PDL
HRRZ A,(A)
SOS T,(FXP) ;COUNT ARGS
CAML T,XC-4 ;NO MORE THAN FOUR ALLOWED
JRST STAT2
STAT6: POP FXP,T ;-<# OF ARGS>
POP FXP,F ;RH IS ADDRESS OF TABLE ENTRY
LDB TT,[410300,,(F)] ;GET STATUS SUBR DISPATCH TYPE
STAT6A: HRRZ D,(F)
JRST STAT7(TT)
STAT7: JSP R,PDLA2(T) ;0 SUBR-TYPE FUNCTION
JRST (D) ;1 LSUBR-TYPE FUNCTION
JRST STSCH ;2 SUBR-TYPE WITH CHAR ARG
JRST STSCH ;3 LSUBR-TYPE WITH CHAR ARG
JRST STSGVAL ;4 GET LISP VALUE
JRST STSSVAL ;5 SET LISP VALUE
JRST STSSTNIL ;6 SET TO T-OR-NIL
MOVE TT,(D) ;7 GET FIXNUM VALUE
JRST FIX1
STAT8: MOVE A,(P)
SETZM (P)
JRST STAT3
STSGVAL: HRRZ A,(D)
CQSSTATUS: POPJ P,QSSTATUS
STSSVAL: POP P,A
JSP T,PDLNMK
STSSV1: MOVEM A,(D)
POPJ P,
STSSTNIL: POP P,A
PUSHJ P,NOTNOT
JRST STSSV1
STLOOK: PUSHJ P,PNGET ;LOOK UP 5 CHARS IN TABLE
HLRZ A,(A) ;F SAYS WHETHER STATUS OR SSTATUS
MOVE TT,(A) ;SKIP ON SUCCESS, LEAVING POINTER IN R
MOVSI R,-LSTBA
CAIE F,QSTATUS
MOVSI R,-LSSTBA
STLK1: CAMN TT,STBA(R)
JRST POPJ1
AOBJN R,STLK1
POPJ P,
STSCH: PUSH FXP,F
PUSH FXP,T
ADDI T,1(P)
HRRZ A,(T)
JSP T,SPATOM
JRST STSCH1
PUSHJ P,PNGET
HLRZ A,(A)
MOVE TT,(A)
LSH TT,-35
JSP T,FXCONS
JRST STSCH2
STSCH1: PUSHJ P,EVAL
JSP T,FXNV1
STSCH2: MOVE T,(FXP)
ADDI T,1(P)
HRRM A,(T)
POP FXP,T
POP FXP,F
LDB TT,[410300,,(F)]
SUBI TT,2
JRST STAT6A
] ;END OF IFN NSTAT
SUBTTL STATUS FEATURES FEATURE NOFEATURE, SSTATUS
SNOFEATURE: PUSH P,CNOT
SFEATURE: HRRZ B,FEATURES
JUMPE A,BRETJ
HLRZ A,(A)
PUSHJ P,MEMQ
JRST NOTNOT
SSFEATURE:
IFE NSTAT, HLRZ A,@(P)
IFN NSTAT, PUSH P,A
HRRZ B,FEATURES
PUSHJ P,MEMQ
JUMPN A,SSFEA2
IFE NSTAT, HLRZ A,@(P)
IFN NSTAT, HRRZ A,(P)
HRRZ B,FEATURES
PUSHJ P,CONS
SSFEA1: MOVEM A,FEATURES
SSFEA2:
IFE NSTAT, POP P,A
IFE NSTAT, JRST CAR
IFN NSTAT, JRST POPAJ
SSNOFEATURE:
IFE NSTAT, HLRZ A,@(P)
IFN NSTAT, PUSH P,A
HRRZ B,FEATURES
PUSHJ P,.DELQ
JRST SSFEA1
IFE NSTAT,[
SSSS: SKIPA F,[-1,,QSTATUS] ;STATUS STATUS
SSSSS: HRROI F,QSSTATUS ;STATUS SSTATUS
SKIPE (P)
JRST SSSSLU
CAMN F,[-1,,QSTATUS]
] ;END OF IFE NSTAT
IFN NSTAT,[
SSSSLU: POP P,A
PUSHJ P,STLOOK
JRST FALSE
JRST TRUE
SSSSS: SKIPA F,CQSSTATUS
SSSS: MOVEI F,QSTATUS
JUMPN T,SSSSLU
PUSH P,R70
CAIN F,QSTATUS
] ;END OF IFN NSTAT
SKIPA F,[-LSTBA,,]
MOVSI F,-LSSTBA
SSSSS1: MOVE T,STBA(F)
MOVEM T,PNBUF
SETOM LPNF
MOVEI C,PNBUF
PUSHJ P,RINTERN
MOVE B,(P)
PUSHJ P,CONS
MOVEM B,(P)
AOBJN F,SSSSS1
JRST POPAJ
SUBTTL STATUS +, STATUS CHTRAN, STATUS SYNTAX
SSPLSS: MOVEI C,RD8N
IFE NSTAT, SKIPE B
IFN NSTAT, SKIPE A
MOVEI C,RD8W
MOVEM C,RDOBJ8
SPLSS: MOVE A,RDOBJ8
SUBI A,RD8N
JRST NOTNOT
SCHTRAN:
SKIPA F,[SKIPA TT,(TT)]
SSYNTAX:
NW% MOVSI F,(HLRZ TT,(TT))
NW$ MOVE F,[LDB TT,[113300+TT,,0]]
PUSH P,CFIX1
SETZ AR1, ;CROCK
JRST SSSYN1
IFE NSTAT,[
SGTSPC: MOVEI A,IN1
SSGTSPC: MOVEI D,GETSP1 ;CROCK
JRST GETSP0
] ;END OF IFE NSTAT
SUBTTL STATUS TTY, SSTATUS TTY
IFN ITS,[
IFE QIO,[
STTY: .SUSET [.RTTY,,TT]
JUMPL TT,FALSE .SEE %TBNOT
.CALL RTTYS
.VALUE
PUSHJ P,CONS1FX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
PUSHJ P,CONSFX
JRST NREVERSE
SSTTY:
IFE NSTAT, MOVE A,B
IFE NSTAT, MOVE B,C
JSP T,FXNV1
JSP T,FXNV2
MOVEM TT,STTYS1
MOVEM D,STTYS2
JSP T,WAKTTY
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
STTY: JUMPN T,STTY1
.SUSET [.RTTY,,TT]
JUMPL TT,FALSE
SKIPA AR1,V%TYI
STTY1: POP P,AR1
PUSHJ P,TIFLOK
.CALL TTYGET
.VALUE
UNLOCKI
MOVE TT,F
PUSHJ P,CONS1FX
MOVE TT,R
PUSHJ P,CONSFX
MOVE TT,D
JRST CONSFX
SSTTY: SETO F,
CAMN T,XC-2
JRST SSTTY9
POP P,AR1
CAIN AR1,TRUTH
MOVE AR1,V%TYI
CAMN T,XC-4
JRST SSTTY4
JSP TT,XFILEP
JRST SSTTY3
SSTTY2: POP P,B
POP P,A
JSP T,FXNV1 ;MOSTLY FOR ERROR CHECKING
JSP T,FXNV2
PUSHJ P,TIFLOK
MOVE D,(A)
MOVEM D,TI.ST1(TT)
MOVE R,(B)
MOVEM R,TI.ST2(TT)
CAME F,XC-1 ;SKIP IF THERE WAS NO ARG FOR THIRD TTY STATUS WORD
JRST SSTTY7
SSTTY1: .CALL TTY2ST
.VALUE
SSTTY8: UNLOCKI
JRST NOTNOT ;FOR (SSTATUS LINMODE)
SSTTY3: JSP T,FXNV4 ;THIRD TTY STATUS WORD
SSTTY9: HRRZ AR1,V%TYI ;DEFAULT TO STANDARD TTY
STTYS: JRST SSTTY2
SSTTY4: POP P,C
JSP T,FXNV3
MOVE F,R
JRST SSTTY2
SSTTY7: .CALL TTYSAC
.VALUE
JRST SSTTY8
TTY2ST: SETZ
SIXBIT \TTYSET\ ;SET TTY VARIABLES
,,F.CHAN(TT) ;CHANNEL #
,,TI.ST1(TT) ;TTYST1
400000,,TI.ST2(TT) ;TTYST2
TTYSAC: SETZ
SIXBIT \TTYSET\ ;SET TTY VARIABLES
,,F.CHAN(TT) ;CHANNEL #
,,D ;TTYST1
,,R ;TTYST2
400000,,F ;TTYSTS
] ;END OF IFN QIO
] ;END OF IFN ITS
IFE QIO,[
SUBTTL STATUS INTERRUPT, SSTATUS INTERRUPT
;;; ********** TABLE OF USER SET INTERRUPT ACTIONS **********
;;; EACH ENTRY IN THIS TABLE IS THE ADDRESS OF A VALUE CELL
;;; CONTAINING AN INTERRUPT HANDLER (A LISP FUNCTION) TO BE RUN
;;; FOR A GIVEN INTERRUPT. IF A TABLE ENTRY HAS THE 4.9 (SETZ)
;;; BIT ON, THEN WHEN THAT INTERRUPT IS RUN THE NOINTERRUPT FLAG
;;; (UNREAL) WILL BE SAVED AND RESTORED OVER THE EXECUTION OF THE
;;; INTERRUPT FUNCTION (SEE UINT0). THIS IS OF CRITICAL IMPORTANCE
;;; TO REAL-TIME INTERRUPT FUNCTIONS SUCH AS THE ALARMCLOCK HANDLER.
UINTTB: SETZ VCN.AT ;0. ↑@ TTY INTERRUPT
Q% SETZ VCN.H ;1. ↑H TTY INTERRUPT (↑H BREAK)
Q$ SETZ VCN.B ;1. ↑B TTY INTERRUPT (↑B BREAK)
SETZ VICA ;2. ↑A TTY INTERRUPT
SETZ VALARMCLOCK ;3. REAL/RUN TIME CLOCK
VERRSET ;4. ERRSET FUNCTION
ERSTBK==.-UINTTB-1 ;INDEX FOR ERRSET BREAKOUT INTERRUPT
VUDF ;5. UNDF-FNCTN BREAK
VUBV ;6. UNBND-VRBL BREAK
VWTA ;7. WRNG-TYPE-ARG BREAK
VUGT ;8. UNSEEN-GO-TAG BREAK
VWNA ;9. WRNG-NO-ARGS BREAK
VGCL ;10. GC-LOSSAGE BREAK
VFAC ;11. FAIL-ACT BREAK
NUIE==.-UINTTB-1-ERSTBK ;# OF CORRECTABLE USER INTERRUPTION ERRORS
VPDL ;12. PDL-OVERFLOW BREAK
VGCO ;13. GC-OVERFLOW BREAK
SETZ VIC34 ;14. ↑\ TTY INTERRUPT
SETZ VIC35 ;15.[ ↑] TTY INTERRUPT (BEWARE: BRACKETS!)
SETZ VIC36 ;16. ↑↑ TTY INTERRUPT
Q% VNIL ;17. (RESERVED FOR FUTURE USE)
Q$ VIOL ;17. IO-LOSSAGE BREAK
Q$ NUIE==.-UINTTB-1-ERSTBK ;# OF CORRECTABLE USER INTERRUPTION ERRORS
VAUTFN ;18. AUTOLOAD INTERRUPT HANDLER
V.TRAP ;19. *RSET HANDLER FOR RETURNING FROM ERROR
VGCDAEMON ;20. GC-DAEMON (RUN AFTER EVERY GC)
LUINTTB==.-UINTTB
SSINTERRUPT: PUSHJ P,SINTERRUPT
IFE NSTAT,[
HRRM C,@UINTTB(D)
JRST CRETJ
] ;END OF IFE NSTAT
IFN NSTAT,[
HRRM B,@UINTTB(TT)
JRST BRETJ
] ;END OF IFN NSTAT
SINT0:
IFE NSTAT, MOVEI A,(B)
WTA [BAD INTERRUPT ## - STATUS!]
IFE NSTAT, MOVEI B,(A)
SINTERRUPT:
IFE NSTAT,[
JSP T,FXNV2
JUMPL D,SINT0
CAIL D,LUINTTB
JRST SINT0
HRRZ AR1,UINTTB(D)
] ;END OF IFE NSTAT
IFN NSTAT,[
JSP T,FXNV1
JUMPL TT,SINT0
CAIN TT,LUINTTB
JRST SINT0
HRRZ AR1,UINTTB(TT)
] ;END OF IFN NSTAT
CAIN AR1,VNIL
JRST SINT0
HRRZ A,(AR1)
POPJ P,
] ;END OF IFE QIO
IFE NSTAT,[
SUBTTL STATUS FREE, STATUS GCMIN, SSTATUS GCMIN
SFREE0: MOVEI A,(AR1) ;BAD SPACE TYPE
%WTA SBADSP
PUSHJ P,NCONS
MOVEM A,(P)
SFREE: HLRZ B,@(P) ;SFREE0 FALLS IN HERE
JSP R,SFRET ;DEMANDS PARTICULAR SYMBOLS
JRST SFREE0 ;BAD SPACE TYPE
JRST SGTSPC ;BPS
MOVEI T,FFS+NFF(TT) ;OTHER
SFRE8: MOVEI TT,FIX1 ;HAIRY MESS TO TAKE LENGTH
MOVEM TT,(P) ; OF FREE STORAGE LIST
SETO TT,
HLLOS NOQUIT
MOVEI R,(T)
SFRE2: JUMPE T,SFRE3
HRRZ T,(T)
AOJA TT,SFRE2
SFRE3: CAIN R,FFA
LSH TT,1
JRST CZECHI
] ;END OF IFE NSTAT
IFE NSTAT,[
SSFRE0: MOVEI A,(AR1) ;BAD SPACE TYPE
%WTA SBADSP
PUSHJ P,NCONS
MOVEM A,(P)
SSFREE: HLRZ B,@(P) ;GET SPACE TYPE
JSP R,SFRET ;FIGURE OUT SPACE TYPE
JRST SSFRE0 ;BAD SPACE TYPE
SETZ TT, ;BPS (TT ZERO IS BPS FLAG)
PUSH FXP,TT ;ELSE TT IS NEGATIVE
POP P,A
JSP T,%CADR
PUSHJ P,EVAL ;EVAL THIRD ARG
POP FXP,TT
JUMPE TT,SSGTSPC ;JUMP OUT IF BPS
JSP T,FXNV1 ;ELSE FAKE OUT SSGS1A INTO
MOVE R,TT ; DOING THE WORK
HLLOS NOQUIT
PUSHJ P,AGC ;NEED TO DO GC TO GET CURRENT
HRRZ D,NFFS+NFF(TT) ; SPACE SIZE (WHY NOT, SEZ I?)
SUBI R,(D)
JUMPLE R,.+2
ADDM R,GFSSIZ+NFF(TT)
MOVEI A,TRUTH
JRST CZECHI
] ;END OF IFE NSTAT
SFRET: CAIN B,QBPS ;FIGURE OUT SPACE TYPE
JRST 1(R) ;BPS => SKIP 1
CAIN B,QRANDOM ;BAD SPACE TYPE => SKIP 0
JRST (R) ;LIST, FIXNUM, FLONUM, BIGNUM,
CAIN B,QARRAY ; SYMBOL, SAR => SKIP 2
MOVEI B,QRANDOM
CAIL B,QLIST
CAILE B,QRANDOM
JRST (R)
2DIF [HRREI TT,(B)]-NFF,QLIST
JRST 2(R)
SUBTTL STATUS UUOLI, SSTATUS UUOLI, STATUS IOC
SUUOLINKS: SKIPN T,LDXSIZ
JRST FALSE ;RETURN NIL IF NO XCT HACKERY HAS BEEN DONE
SETZB TT,D ;ZERO COUNTER
TLNE T,400000
MOVEI D,TRUTH ;D GETS TRUE IF PURIFIED
MOVNS T ;MAKE UP AOBJN POINTER FOR XCT CALL AREA 2
HLL T,LDXBLT
MOVSS T
SUUOL1: SKIPN (T) ;COUNT FREE CELLS IN XCT CALL AREA
AOS TT
AOBJN T,SUUOL1
JSP T,FIX1A ;RETURN LIST OF PURE FLAG AND COUNT
PUSHJ P,NCONS
MOVE B,D
JRST XCONS
SSUUOLINKS: SKIPN TT,LDXBLT ;ZAP CALLS FOR XCTS WITH A BLT
JRST FALSE
MOVEI T,(TT)
ADD T,LDXSM1
BLT TT,(T)
JRST TRUE
IFE QIO,[
SIOC:
IFE NSTAT, JSP T,FXNV2
IFN NSTAT, JSP T,FXNV1
MOVSI AR2A,-LSIOCT
SIOC1: MOVE AR1,SIOCT(AR2A)
IFE NSTAT, CAIN D,(AR1)
IFN NSTAT, CAIN TT,(AR1)
JRST SIOC2
AOBJN AR2A,SIOC2
MOVEI A,(B)
WTA [BAD CHARACTER - STATUS IOC!]
MOVEI B,(A)
JRST SIOC
SIOC2: MOVSS AR1
HRRZ A,(AR1)
CAIL AR2A,SIOCTI
JRST NOT
JRST NOTNOT
SIOCT:
IRPS A,,[SIGNAL,LPTON,GCGAGV,TAPRED,TAPWRT,TTYOFF]B,,[A,B,D,Q,R,W]
A,,"B
TERMIN
IFN MOBIOF, IPLOPD,,"P
IFN MOBIOF,[
DISON,,"F
DISPON,,"N
]
SIOCTI==.-SIOCT
IRPS A,,[LPTON,GCGAGV,TAPRED,TAPWRT,TTYOFF]B,,[E,C,S,T,V]
A,,"B
TERMIN
IFN MOBIOF, IPLOPD,,"U
IFN MOBIOF, DISPON,,"Y
LSIOCT==.-SIOCT
SUREAD: SKIPE A,UTIOPD
JRST SURD1
POPJ P,
SUWRITE: SKIPE A,UTOOPD
MOVE A,UWUNIT
POPJ P,
] ;END OF IFE QIO
SUBTTL STATUS TIME, DATE, UNAME, XUNAME, JNAME, LINMODE
IFN ITS,[
STIME: .RTIME TT,
JRST SDATE+1
SDATE: .RDATE TT,
AOJE TT,FALSE
MOVE D,TT
SUB D,[202020202021]
JSP F,STCVT
JSP F,STCVT
JSP F,STCVT
MOVNI T,3
JRST LIST
STCVT: SETZB TT,R
LSHC TT,6
IMULI TT,10.
ROTC D,6
ADD TT,R
JSP T,FIX1A
PUSH P,A
JRST (F)
SXUNAME: SKIPA T,[.RXUNAME,,0]
SXJNAME: HRLI T,.RXJNAME
JRST SUNAM0
SJNAME: SKIPA T,[.RJNAME,,0]
SUNAME: HRLI T,.RUNAME
SUNAM0: HRRI T,UNMTMP
.SUSET T
SUNAM1: MOVE A,[440600,,UNMTMP]
SETZM UNMTMP+1
JRST READ6C
IFE QIO,[
ZZX==<%TG<ACT>>*010101010101 ;6 %TGACT BITS
SSLINMODE:
IFN NSTAT, SKIPN A
IFE NSTAT, SKIPN B
SKIPA T,[STTYW1&ZZX]
SKIPA T,[STTYL1&ZZX]
SKIPA TT,[STTYW2&ZZX]
SKIPA TT,[STTYL2&ZZX]
TDZA A,A
MOVEI A,TRUTH
MOVEM A,LINMODE
MOVE D,[ZZX]
ANDCAM D,STTYS1
XCTPRO
ANDCAM D,STTYS2
IORM T,STTYS1 ;CLOBBER IN ONLY ACTIVATION BITS
IORM TT,STTYS2
NOPRO
JSP T,WAKTTY
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
ZZX==<%TG<ACT>>*010101010101 ;6 %TGACT BITS
SSLINMODE: CAMN T,XC-1
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
SKIPN A
SKIPA R,[STTYW1&ZZX]
SKIPA R,[STTYL1&ZZX]
SKIPA F,[STTYW2&ZZX]
MOVE F,[STTYL2&ZZX]
MOVE D,[ZZX]
ANDCAM D,TI.ST1(TT)
IORM R,TI.ST1(TT) ;CLOBBER IN ONLY ACTIVATION BITS
ANDCAM D,TI.ST2(TT)
IORM F,TI.ST2(TT)
JRST SSTTY1
] ;END OF IFN QIO
] ;END OF IFN ITS
IFN D10,[
IFE SAIL,[
SDATE: MOVE R,[56,,11] ;%CNYER,,.GTCNF
MOVE D,[57,,11] ;%CNMON,,.GTCNF
MOVE TT,[60,,11] ;%CNDAY,,.GTCNF
GETTAB R,
JRST FALSE
SUBI R,1900.
JRST STIM2
STIME: MOVE R,[61,,11] ;%CNHOR,,.GTCNF
MOVE D,[62,,11] ;%CNMIN,,.GTCNF
MOVE TT,[63,,11] ;%CNSEC,,.GTCNF
GETTAB R,
JRST FALSE
STIM2: GETTAB D,
JRST FALSE
GETTAB TT,
JRST FALSE
PUSHJ P,CONS1FX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
JSP T,FXCONS
JRST CONS
] ;END OF IFE SAIL
IFN SAIL,[
SDATE: DATE D, ;DATE IN D
IDIVI D,31. ;REMAINDER IN R IS DAYS-1
AOJ R, ;DAY IN R
PUSH FXP,R ;ON STACK
IDIVI D,12. ;FIGURE OUT
AOJ R, ;MONTH
PUSH FXP,R ;ON STACK
ADDI D,64. ;LOSING YEAR IN D
MOVE R,D ;NOW IN R
POP FXP,D ;MONTH IN D
POP FXP,TT ;DAY IN TT
JRST STIM2
STIME: TIMER TT, ;GET TIME IN TT
IDIVI TT,3600.
PUSH FXP,D ;SECONDS ON STACK
IDIVI TT,60. ;MINUTES
PUSH FXP,D ;ON STACK
MOVE R,TT ;HOURS IN R
POP FXP,D ;MINUTES IN D
POP FXP,TT ;SECONDS IN TT
STIM2: PUSHJ P,CONS1FX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
JSP T,FXCONS
JRST CONS
] ;END OF IFN SAIL
SXJNAME:
SJNAME: MOVE TT,D10NAM
MOVEM TT,UNMTMP
SETZM UNMTMP+1
MOVE A,[440600,,UNMTMP]
JRST READ6C
SXUNAME:
SUNAME: GETPPN D,
JFCL
IFE SAIL,[
SUNM2: HRRZ TT,D
PUSHJ P,CONS1FX
HLRZ TT,D
JRST CONSFX
] ;END OF IFE SAIL
IFN SAIL,[
SUNM2: HRLZM D,UNMTMP ;PROG IN UNMTMP
MOVE A,[440600,,UNMTMP] ;BYTE PTR FOR UNAME
MOVEM A,UNMTMP+1 ;SAVE BYTE PTR HERE FOR SAILFN HACK
PUSHJ P,SAILFN ;TO LOCAL HACK.
MOVE A,UNMTMP+1 ;GRAB NEW PTR BACK FOR READ6C
SETZM UNMTMP+1 ;NEXT WORD ZEROS
PUSH FXP,D
PUSHJ P,READ6C ;USE READER TO MAKE ATOM AND INTERN IT
PUSHJ P,NCONS ;(LIST PROG)
POP FXP,D
PUSH FXP,A ;SAVE ON STACK
HLLZM D,UNMTMP ;PROJ IN UNMTMP
MOVE A,[440600,,UNMTMP] ;BYTE PTR FOR UNAME
MOVEM A,UNMTMP+1 ;SAVE BYTE PTR HERE FOR SAILFN HACK
PUSHJ P,SAILFN ;TO LOCAL HACK.
MOVE A,UNMTMP+1 ;GRAB NEW PTR BACK FOR READ6C
SETZM UNMTMP+1 ;NEXT WORD ZEROS
PUSHJ P,READ6C ;INTERN IT
POP FXP,B ;(LIST PROG) IN B
JRST CONS ;(CONS PROJ (LIST PROG)))
SAILFN: MOVE T,UNMTMP+1 ;GRAB BYTE PTR
ILDB A,T ;INCREMENT AND LOAD IT
CAIE A,0 ;IS IT NULL?
POPJ P, ;NO, SO WIN
IBP UNMTMP+1 ;OTHER POINTER
JRST SAILFN+1 ;AGAIN
] ;END OF IFN SAIL
] ;END OF IFN D10
SUBTTL STATUS DOW, STATUS MEMFREE
IFN USELESS,[
IFN ITS,[
SDOW: .RYEAR TT,
AOJE TT,FALSE
LSH TT,-31
ANDI TT,16
MOVE T,SDOWQX(TT)
MOVEM T,PNBUF
MOVE T,SDOWQX+1(TT)
MOVEM T,PNBUF+1
MOVEI C,PNBUF+1
SETOM LPNF
JRST RINTERN
SDOWQX:
IRP DAY,,[SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY]
ASCII \DAY\
TERMIN
] ;END OF IFN ITS
IFN D10,[
SDOW:
IFE SAIL,[
MOVE T,[53,,11] ;%CNDTM,,.GTCNF
GETTAB T,
JRST FALSE ;SAIL DATE
HLRZS T
] ;END OF IFE SAIL
.ELSE [
DATE T, ;DATE IN T
CALLI T,400100 ;CONVERT TO # OF SECONDS SINCE MIDNIGHT
]
IDIVI T,7
LSH TT,1
MOVE T,SDOWQX(TT)
MOVEM T,PNBUF
MOVE T,SDOWQX+1(TT)
MOVEM T,PNBUF+1
MOVEI C,PNBUF+1
SETOM LPNF
JRST RINTERN
SDOWQX: ;FUNNY ORDER FOR DEC-10
IRP DAY,,[WEDNESDAY,THURSDAY,FRIDAY,SATURDAY,SUNDAY,MONDAY,TUESDAY]
ASCII \DAY\
TERMIN
] ;END OF IFN D10,
] ;END OF IFN USELESS
SMEMFREE:
10% MOVE TT,HINXM ;NUMBER OF WORDS IN HOLE
10% SUB TT,BPSH ;INTERRUPT HERE WOULD SCREW,
10$ MOVE TT,MAXNXM
10$ SUB TT,HIXM
JRST FIX1 ; WORRY, WORRY, WHO CARES
SUBTTL STATUS ABBREVIATE
IFN USELESS,[
IFE NSTAT,[
SABBREVIATE: JSP T,RSXST
MOVEI A,LRCT-2
HRRZ TT,@RSXTB
TLNN AR1,200000 ;200000 IMPLIES WAS SSTATUS
JRST FIX1
SKIPN D,B
JRST SABBR1
MOVEI D,3
CAIE B,TRUTH
JSP T,FXNV2
SABBR1: HRRM D,@RSXTB
JRST BPDLNKJ
] ;END OF IFE NSTAT
IFN NSTAT,[
SABBREVIATE:
MOVEI TT,LRCT-2
HRRZ A,VREADTABLE
HRRZ TT,@TTSAR(A)
JRST FIX1
SSABBREVIATE:
SKIPN TT,A
JRST SSABB1
MOVEI TT,3
CAIE A,TRUTH
JSP T,FXNV1
SSABB1: MOVEI T,(TT)
MOVEI TT,LRCT-2
HRRZ B,VREADTABLE
HRRM T,@TTSAR(B)
JRST PDLNKJ
] ;END OF IFN NSTAT
] ;END OF IFN USELESS
SUBTTL STATUS SYSTEM
IFE NSTAT, SSYSTEM: SKIPA A,B
SSYST0: WTA [SYMBOL REQUIRED - STATUS SYSTEM!]
IFN NSTAT, SSYSTEM:
JSP T,SPATOM
JRST SSYST0
JUMPE A,SSYST6
CAIN A,TRUTH
JRST SSYST6
MOVEI AR1,NIL
MOVEI B,QVALUE
HLRZ C,(A)
HRRZ C,(C)
CAIGE C,ESYSVC
JRST SSYST4
SSYST1: MOVEI B,SSSBRL
PUSHJ P,GETLA
JUMPE A,AR1RETJ
HLRZ B,(A)
HRRZ A,(A)
HLRZ C,(A)
CAIE B,QAUTOLOAD
JRST SSYST3
CAIL C,BSYSAP ;IS IT A SYSTEM AUTOLOAD PROP?
CAIL C,ESYSAP
JRST SSYST1 ;NOPE
JRST SSYST4 ;YUP
SSYST3: CAIE B,QARRAY
JRST SSYST5
CAIL C,BSYSAR ;IS IT A SYSTEM ARRAY
CAIL C,ESYSAR
JRST SSYST1
JRST SSYST4
SSYST5: CAIL C,ENDFUN ;SUBR OR VC ADDRESS IN SYSTEM AREA
JRST SSYST1
SSYST4: EXCH A,AR1 ;A WIN, SO CONS UP THIS PROPERTY NAME
PUSHJ P,XCONS
EXCH A,AR1
JRST SSYST1
SSYST6: MOVEI A,QVALUE
JRST NCONS
SUBTTL STATUS GCTIME, LISPVERSION, TTYREAD, ←, TERPRI
SSGCTIM:
IFE NSTAT, MOVE A,B
JSP T,FXNV1
10% LSH TT,-2
10$ IDIVI TT,1000.
EXCH TT,GCTIM
JRST SGCTM1
SGCTIM: MOVE TT,GCTIM
SGCTM1: PUSH P,CFIX1 ;FAKE OUT ENTRY INTO RUNTIME
JRST RNTM1
SLVRNO: MOVE A,[440600,,[LVRNO]]
JRST READ6C
IFE QIO,[
STTYREAD: MOVEI TT,LRCT-2
JRST SLAP1
STERPRI: SKIPA TT,[LRCT-1]
] ;END OF IFE QIO
SLAP: HRROI TT,LRCT-1
SLAP1: HRRZ A,VREADTABLE
MOVE A,@TTSAR(A)
SKIPL TT
MOVSS A
JRST RHAPJ
IFE QIO,[
SSTTYREAD: MOVEI R,LRCT-2
JRST SSLAP1
SSTERPRI: SKIPA R,[LRCT-1]
] ;END OF IFE QIO
SSLAP: HRROI R,LRCT-1
SSLAP1:
IFE NSTAT, MOVE A,B
PUSHJ P,NOTNOT
HRRZ D,VREADTABLE ;INTERRUPT COULD SCREW HERE (FOO)
JSP T,.STOR0
POPJ P,
IFN QIO,[
SLINMODE: SKIPA F,[FBT<LN>,,]
STTYREAD: MOVSI F,FBT<FR>
SKIPN T
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
TDNN F,F.MODE(TT)
TDZA A,A
MOVEI A,TRUTH
TLNE F,FBT<FR>
PUSHJ P,NOT
UNLKPOPJ
SSTTYREAD:
CAMN T,XC-1
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
POP P,A
MOVSI F,FBT<FR>
ANDCAM F,F.MODE(TT)
SKIPN A
IORM F,F.MODE(TT)
UNLOCKI
JRST NOTNOT
STERPRI:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
STERP1: SKIPLE FO.LNL(TT)
TDZA A,A
MOVEI A,TRUTH
UNLKPOPJ
SSTERPRI:
CAMN T,XC-1
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
POP P,A
MOVMS FO.LNL(TT)
SKIPE A
MOVNS FO.LNL(TT)
JRST STERP1
] ;END OF IFN QIO
SUBTTL STATUS CRFILE, LOSEF
IFN QIO,[
SCRFUN==FALSE ;***** TEMP CROCK *****
SCRFIL: SETZ A,
PUSHJ P,DEFAULTF
HRRZ A,(A)
POPJ P,
] ;END OF IFN QIO
IFE QIO,[
SSCRFIL:
IFE NSTAT, MOVE A,(P)
IFN NSTAT, PUSH P,A
PUSHJ P,UFNAME
JRST POPAJ
SCRFIL: PUSH P,[440600,,UFN1]
MOVE A,[440600,,UFN2]
PUSHJ P,READ6C
PUSHJ P,NCONS
JRST SCRFL1
SURD1: PUSH P,[440600,,URFN1]
MOVE A,[440600,,URFN2]
PUSHJ P,READ6C
MOVE B,URUNIT
PUSHJ P,CONS
SCRFL1: EXCH A,(P)
PUSHJ P,READ6C
POP P,B
JRST CONS
SCRFUN: PUSHJ P,SCRFIL
MOVE B,IUNIT
JRST .NCONC
] ;END OF IFE QIO
SLOSEF: MOVE T,LOSEF
JFFO T,.+1
MOVNS TT
ADDI TT,36.
JRST FIX1
SSLOS0: MOVEI A,(B)
WTA [BAD LOSEF - SSTATUS!]
IFN NSTAT, SSLOSEF:
MOVEI B,(A)
IFE NSTAT, SSLOSEF:
SKIPE GCPSAR
JRST SLOSEF
JSP T,FXNV2
JUMPLE D,SSLOS0
CAILE D,16
JRST SSLOS0
MOVEI TT,1
LSH TT,(D)
SUBI TT,1
MOVEM TT,LOSEF
BPDLNKJ: MOVEI A,(B)
JRST PDLNKJ
SUBTTL STATUS JCL, HACTRN
IFN D10,[
SJCL: SKIPN T,SJCLBUF
JRST FALSE
PUSH FXP,T
PUSH FXP,[440700,,SJCLBUF+1]
SJCL2: ILDB TT,(FXP)
PUSHJ P,RDCH2
PUSH P,A
SOSLE -1(FXP)
JRST SJCL2
SJCL4: MOVE T,SJCLBUF
SUB FXP,R70+2
JRST LIST
] ;END OF IFN D10
IFN ITS,[
SDDTP: SETZ A,
.SUSET [.ROPTION,,TT]
TLNE TT,OPTDDT
MOVEI A,QDDT
TLNE A,OPTLSP
MOVEI A,QLISP
POPJ P,
SJCL: .SUSET [.ROPTION,,TT]
TLNE TT,OPTBRK
TLNN TT,OPTCMD
JRST FALSE ;EXIT WITH NIL IF NO COMMAND LINE
SETZM JCLBF
MOVE T,[JCLBF,,JCLBF+1]
BLT T,JCLBF+LJCLBF-1
HLLOS JCLBF+LJCLBF-1
.BREAK 12,[..RJCL,,JCLBF]
PUSH FXP,R70
PUSH FXP,[440700,,JCLBF]
SJCL1: ILDB TT,(FXP)
JUMPE TT,SJCL3
SJCL2: PUSH P,TT
PUSHJ P,RDCH2
EXCH A,(P)
SOS -1(FXP)
CAIE A,↑M ;CAR-RET CAUSES TERMINATION
JRST SJCL1
SJCL4: MOVE T,-1(FXP)
SUB FXP,R70+2
JRST LIST
SJCL3: HRRZ T,(FXP)
CAIE T,JCLBF+LJCLBF-1
JRST SJCL4
MOVEI A,QSJCL
FAC [TOO MUCH JCL - STATUS!]
SUBTTL STATUS TTYSIZE, TTYTYPE
IFE QIO,[
STTYSIZE: .CALL RSSBLK ;RETURNS (TTYHEIGHT . TTYWIDTH)
.VALUE
JSP T,FXCONS
MOVEI B,(A)
MOVE TT,D
JRST CONSFX
] ;END OF IFE QIO
IFN QIO,[
STTYTYPE: TDZA F,F
STTYSIZE: MOVEI F,1
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
.CALL STTSZ9
.VALUE
UNLOCKI
JUMPN F,STTYS1
MOVE TT,R
JRST FIX1
STTYS1: JSP T,FXCONS
MOVEI B,(A)
MOVE TT,D
JRST CONSFX
STTSZ9: SETZ
SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS
,,F.CHAN(TT) ;CHANNEL #
2000,,D ;VERTICAL SCREEN SIZE
2000,,TT ;HORIZONTAL SCREEN SIZE
402000,,R ;TCTYP
;TTYCOM, TTYOPT, TTYTYP NOT RETRIEVED
] ;END OF IFN QIO
] ;END OF IN ITS
SUBTTL STATUS TTYSCAN, TTYCONS, TTYINT
IFN QIO,[
STTYSCAN: SKIPN T ;GET TTY PRE-SCAN FUNCTION
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
HRRZ A,TI.BFN(TT)
UNLKPOPJ
SSTTYSCAN: CAMN T,XC-1 ;SET TTY PRE-SCAN FUNCTION
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
POP P,A
HRRZM A,TI.BFN(TT)
UNLKPOPJ
STTYCONS: MOVEI AR1,(A) ;GET ASSOCIATED TTY FILE OF
CAIN AR1,TRUTH ; OPPOSITE DIRECTION, IF ANY
HRRZ AR1,V%TYI ;PREFER INPUT TTY
PUSHJ P,TFILOK ;LEAVES ITS ARGUMENT IN AR1
HRRZ A,FT.CNS(TT) .SEE TTYMOR
UNLKPOPJ
SSTTYCONS:
SKIPE A ;CONS TOGETHER TWO TTY'S INTO
CAIN A,TRUTH ; A SINGLE CONSOLE
EXCH A,B ;PREFER TO SEE NIL OR T SECOND
CAIN A,TRUTH ;PREFER INPUT TTY FOR FIRST ARG
HRRZ A,V%TYI
MOVEI AR1,(A)
PUSHJ P,TFILOK
JUMPE B,SSTC1 ;SUNDER THEM IF ONE IS NIL
MOVEI T,TIFLOK
TLNN TT,TTS<IO>
MOVEI T,TOFLOK
UNLOCKI
CAIE B,TRUTH
JRST SSTC2
HRRZ B,V%TYI ;FOR SECOND ARG OF T, USE TTY
TLNN TT,TTS<IO> ; OF NECESSARY DIRECTION
HRRZ B,V%TYO
SSTC2: MOVEI AR1,(B)
PUSHJ P,(T)
HRRZ C,FT.CNS(TT)
HRRZM A,FT.CNS(TT) ;LINK THIS ONE TO THAT ONE
MOVEI TT,FT.CNS
SKIPE C ;IF IT WAS LINKED, UNLINK
SETZM @TTSAR(C) ; ITS FORMER PARTNER
EXCH B,@TTSAR(A) ;LINK THAT ONE TO THIS ONE
JUMPE B,UNLKTRUE ;????? THINK ABOUT ALL THIS?
CAIE B,(A) ;IF IT WAS LINKED, UNLINK
SETZM @TTSAR(B) ; ITS FORMER PARTNER
JRST UNLKTRUE
SSTC1: HRRZ B,FT.CNS(TT) ;GET ASSOCIATED TTY
SETZM FT.CNS(TT) ;UNLINK THAT FROM THIS
MOVEI TT,FT.CNS
SETZM @TTSAR(B) ;UNLINK THIS FROM THAT
JRST UNLKTRUE
;;; IFN QIO
STTYINT:
CAMN T,XC-1
SKIPA AR1,V%TYI
POP P,AR1
POP P,A
JSP T,CHNV1
MOVE F,TT
PUSHJ P,TIFLOK
ROT F,-1
ADDI TT,FB.BUF(F)
HRRZ A,(TT)
SKIPL F
HLRZ A,(TT)
UNLKPOPJ
SSTTYINT:
CAMN T,XC-2
SKIPA AR1,V%TYI
POP P,AR1
POP P,A
JSP T,PDLNMK
MOVEI B,(A)
POP P,A
JSP T,CHNV1
MOVE F,TT
PUSHJ P,TIFLOK
ROT F,-1
ADDI TT,FB.BUF(F)
JUMPL F,SSTIN1
HRLM B,(TT)
JRST UNLKTRUE
SSTIN1: HRRM B,(TT)
JRST UNLKTRUE
] ;END OF IFN QIO
SUBTTL STORAGE SPACE STATUS CALLS
SPDLMAX:
IFN ITS,[
JSP D,SSGP1 ;0 - STATUS PDLMAX
SSPDLMAX: JSP D,SSGP1 ;1 - SSTATUS PDLMAX
] ;END OF IFN ITS
.ELSE REPEAT 2, 0 ;0, 1 UNUSED
SGCSIZE: JSP D,SSGP1 ;2 - STATUS GCSIZE
SSGCSIZE: JSP D,SSGP1 ;3 - SSTATUS GCSIZE
SGCMAX: JSP D,SSGP1 ;4 - STATUS GCMAX
SSGCMAX: JSP D,SSGP1 ;5 - SSTATUS GCMAX
SGCMIN: JSP D,SSGP1 ;6 - STATUS GCMIN
SSGCMIN: JSP D,SSGP1 ;7 - SSTATUS GCMIN
SPDLSIZE: JSP D,SSGP1 ;10 - STATUS PDLSIZE
IFE NSTAT, SPURSIZE: SKIPA AR1,B ;14 - STATUS PURSIZE
IFN NSTAT, SPURSIZE: SKIPA B,A ;14 - STATUS PURSIZE
SSPCSIZE: JSP D,SSGP1 ;12 - STATUS SPCSIZE
BG$ CAILE B,QBIGNUM ;BEWARE! KLUDGY CODE!
BG% CAILE B,QFLONUM
MOVEI B,QRANDOM
MOVEI D,14 ;FAKE OUT A JSP D,SSGP1
IFE NSTAT, JRST SSGP1B
IFN NSTAT, JRST SSGP1A
SPDLROOM: MOVEI D,20+SPDLMAX+1 ;20 - STATUS PDLROOM
SSGP1: SUBI D,SPDLMAX+1 ;GET CODE NUMBER IN D
IFN NSTAT, MOVEI C,(B) ;QUICK AND DIRTY PATCH FOR NSTAT
IFN NSTAT, MOVEI B,(A)
SSGP1A: MOVEI AR1,(B)
IFE NSTAT, SSGP1B:
CAIN B,QRANDOM ;GET LINEARIZATION BY USING
JRST SSGPLZ ; QRANDOM FOR QARRAY
CAIN B,QARRAY
MOVEI B,QRANDOM
TRNE D,6 ;SKIP IF PDLMAX OR PDLSIZE
JRST SSGP1C
CAIL B,QREGPDL
CAILE B,QSPECPDL
JRST SSGPLZ
JRST SSGP1D
SSGP1C: CAIG B,QRANDOM ;LOSE IF BAD SPACE TYPE
CAIGE B,QLIST
JRST SSGPLZ
SSGP1D: ROT D,-1 ;LOW BIT=1 => SSTATUS
JUMPL D,SSGP3
MOVE TT,@SSGPGT(D) ;ELSE GET VALUE TO RETURN
TRNE D,3
JRST SSGP2A
2DIF [SUB TT,(B)]C2,QREGPDL ;FOR PDL STUFF, CUT DOWN
TLZ TT,-1 ; QUANTITY BY PDL ORIGIN
SSGP2A: TLNN TT,-1 ;HACK SO THAT STATUS GCMIN
JRST FIX1 ; WILL RETURN A FLONUM
JRST FLOAT1 ; IF APPROPRIATE
SSGPGT:
10% 2DIF (B),XPDL,QREGPDL ;PDLMAX
10$ 0 ;UNUSED
10X WARN [FOO]
2DIF (B),GFSSIZ,QLIST ;GCSIZE
2DIF (B),XFFS,QLIST ;GCMAX
2DIF (B),MFFS,QLIST ;GCMIN
2DIF (B),P,QREGPDL ;PDLSIZE
2DIF (B),SFSSIZ,QLIST ;SPCSIZE
2DIF (B),PFSSIZ,QLIST ;PURSIZE
0 ;UNUSED
2DIF (B),OC2,QREGPDL ;PDLROOM
SSGPLZ: MOVEI T,SBADSP ;BAD SPACE TYPE (OR MAYBE PDL TYPE?)
TRNN D,6
MOVEI T,[SIXBIT \BAD PDL TYPE - STATUS!\]
MOVEI A,(AR1)
%WTA (T)
MOVEI B,(A)
JRST SSGP1A
SSGP3$: JUMPE C,TRUE ;USED BY $ALLOC
SSGP3: TRC D,3
TRCN D,3
JRST SSGP4 ;JUMP IF (SSTATUS GCMIN ...)
SSGP3A: JSP T,FXNV3 ;ELSE WANT A FIXNUM
TLNE R,-1 ;LOSE IF NEG OR TOO LARGE
JRST FALSE
JRST SSGPPT(D) ;ELSE JRST TO SPECIAL ROUTINE
SSGPPT:
10% JRST SSPM1 ;PDLMAX
10$ 0
10X WARN [FOO]
JRST SSGS1 ;GCSIZE
JRST SSGX1 ;GCMAX
SSGM1: CAIL R,40 ;GCMIN
2DIF [CAMLE D,(B)]SSGMRV,QLIST ;FIXNUM GCMIN MUST HAVE
JRST FALSE ; "REASONABLE" VALUE
SSGM2:
2DIF [MOVEM R,(B)]MFFS,QLIST ;SO SAVE IT, ALREADY
JRST TRUE
SSGMRV: 20000 ;LIST
10000 ;FIXNUM
4000 ;FLONUM
BG$ 4000 ;BIGNUM
4000 ;SYMBOL
1000 ;SAR
SSGP4: MOVEI A,(C) ;(SSTATUS GCMIN ...) PERMITS
JSP T,FLTSKP ; A FLONUM ARGUMENT
JRST SSGP3A
JUMPLE TT,FALSE ;BUT MUST BE POSITIVE
CAML TT,[.005] ; AND BETWEEN .005 AND .95
CAMLE TT,[.95]
JRST FALSE
MOVE R,TT
JRST SSGM2
SSGS1: ANDI R,SEGMSK
2DIF [MOVEM R,(B)]GFSSIZ,QLIST ;SET GCSIZE
2DIF [CAMG R,(B)]XFFS,QLIST ;IF GREATER THAN GCMAX,
JRST TRUE ; MUST ALSO SET GCMAX TO MATCH
SSGX1:
2DIF [CAMGE R,(B)]SFSSIZ,QLIST ;GCMAX MAY NOT BE LESS
JRST FALSE ; THAN ACTUAL SIZE
XCTPRO
2DIF [HRRZM R,(B)]XFFS,QLIST
NOPRO
JRST TRUE
IFN ITS,[
SSPM1: HRRZ T,P-QREGPDL(B) ;GET CURRENT PDL POINTER
ADD R,C2-QREGPDL(B) ;UP USER'S VALUE BY PDL ORIGIN
ANDI R,777760
TRNN R,PAGKSM
SUBI R,20
CAILE R,(T) ;NEW PDLMAX MUST BE ABOVE
CAML R,OC2-QREGPDL(B) ; CURRENT PDL POINTER, AND
JRST FALSE ; BELOW ABS OVERFLOW POINT
HRRZM R,XPDL-QREGPDL(B)
HRRZM R,ZPDL-QREGPDL(B) ;SO UPDATE CRAP
HRROS P-QREGPDL(B) ;SET LH OF PDL POINTER TO -1
JRST TRUE ; SO PDLOV WILL HACK IT PROPERLY
] ;END OF IFN ITS
;;; PART OF PUTPROP - HACK FOR *PURE MODE TO PURIFY PROPERTY LISTS
CSETP1: PUSH P,B
MOVEI A,(C)
MOVE B,VPUTPROP
PUSHJ P,MEMQ
POP P,B
JUMPE A,CSETP7
MOVEI A,(B)
PUSHJ P,PURCOPY
MOVE T,(P)
CSETP2: HRRZ B,(T)
JUMPE B,CSETP3
MOVEI TT,(B)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,PUR
JRST CSETP3
HRRZ T,(B)
JRST CSETP2
CSETP3: PUSHJ P,PCONS
MOVEI B,(A)
MOVEI A,(C)
PUSHJ P,PCONS
HRRM A,(T)
SUB P,R70+1
JRST $CADR
CSETP7: HRRZ A,(P)
JRST CSET2A
IFN NSTAT,[
IFN USELESS,[
IFN ITS,[
SUBTTL STATUS WHO-LINE [ETC.]
SSWHO1: SETZ F,
MOVE D,[441000,,F]
JSP T,FXNV1
IDPB TT,D
MOVEI A,(B)
JSP T,CHNV1X
IDPB TT,D
JSP T,FXNV3
IDPB R,D
MOVEI A,(AR1)
JSP T,CHNV1X
IDPB TT,D
.SUSET [.SWHO1,,F]
JRST TRUE
SSWHO2: PUSHJ P,SIXNUM
.SUSET [.SWHO2,,TT]
JRST TRUE
SSWHO3: PUSHJ P,SIXNUM
.SUSET [.SWHO3,,TT]
JRST TRUE
SWHO1: .SUSET [.RWHO1,,F]
MOVEI R,4
SETZ B,
MOVE D,[441000,,F]
SWHO1A: ILDB TT,D
JSP T,FXCONS
PUSHJ P,CONS
MOVEI B,(A)
SOJG R,SWHO1A
JRST NREVERSE
SWHO2: .SUSET [.RWHO2,,TT]
JRST FIX1
SWHO3: .SUSET [.RWHO3,,TT]
JRST FIX1
SIXNUM: SKOTT A,FX
JRST SIXMAK
POP P,T
JRST FXNV1
;;; IFN NSTAT
;;; IFN USELESS
;;; IFN ITS
IFN QIO,[
SMAR: MOVE T,INTMSK
TRNN T,%PI<MAR> ;NIL IF LISP NOT USING MAR
JRST FALSE ; (BUT SUPERIOR MIGHT BE)
.SUSET [.RMARA,,D]
HLRZ TT,D
MOVEI A,(D)
PUSHJ P,ACONS
MOVEI B,(A)
JRST CONSFX ;RETURN LIST OF (MODE, LOCATION)
SSMAR: MOVEI F,IB<MAR>
JSP T,FXNV1
TRZ TT,4
JUMPE TT,SSMAR5
IORM F,INTMSK
.SUSET [.SIMASK,,F]
HRLI B,(TT)
.SUSET [.SMARA,,B]
JRST TRUE
SSMAR5: .SUSET [.SMARA,,R70]
ANDCAM F,INTMSK
.SUSET [.SAMASK,,F]
JRST TRUE
SFTV: TDZA AR2A,AR2A ;MOBY I/O CRUD
SSFTV: MOVEI AR2A,1 ;AUTOLOADS FROM COM:NVID FASL
JCALL 5,QSFTV.
SFTVSIZE: MOVEI AR2A,2
JCALL 5,QSFTV.
SSFTVSIZE: MOVEI AR2A,3
JCALL 5,QSFTV.
SFTVTITLE: MOVEI AR2A,4
JCALL 5,QSFTV.
SSGCWHO: JSP T,FXNV1
ANDI TT,3
MOVEM TT,GCWHO
JRST TRUE
;;; IFN NSTAT
;;; IFN USELESS
;;; IFN ITS
SITS: .CALL SITS9
.VALUE
PUSH FXP,T
JSP T,IFLOAT
FDVRI TT,(30.0)
JSP T,FLCONS
SETZ B,
PUSHJ P,CONSIT
POP FXP,TT
PUSHJ P,CONSFX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
PUSHJ P,CONSFX
MOVE TT,F
JSP T,IFLOAT
SKIPL TT
FDVRI TT,(30.0)
JSP T,FLCONS
JRST CONS
SITS9: SETZ
SIXBIT \SSTATU\
2000,,F ;TIME UNTIL SYSTEM GOES DOWN
2000,,R ;SYSTEM BEING DEBUGGED
2000,,D ;NUMBER OF LOSERS
2000,,T ;NUMBER OF MEMORY ERRORS
402000,,TT ;TIME SYSTEM HAS BEEN UP
] ;END OF IFN QIO
] ;END OF IFN ITS
] ;END OF IFN USELESS
] ;END OF IFN NSTAT
SUBTTL ASCII TABLE OF STATUS FUNCTIONS
;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 1 *****
STBA:
Q% ASCII \IOC\ ;IOC (I/O CONTROL)
ASCII \MACRO\ ;MACRO
ASCII \DIVOV\ ;DIVOV (DIVIDE OVERFLOW)
ASCII \TTY\ ;TTY
IFE NSTAT, ASCII \FREE\ ;FREE (CELLS IN A SPACE)
ASCII \TOPLE\ ;TOPLEVEL
ASCII \BREAK\ ;BREAKLEVEL
ASCII \UREAD\ ;UREAD
ASCII \UWRIT\ ;UWRITE
ASCII \+\ ;+ (SUPRA-DECIMAL DIGITS OPTION)
ASCII \GCMIN\ ;GCMIN
ASCII \SYNTA\ ;SYNTAX
ASCII \CHTRA\ ;CHTRAN (CHARACTER TRANSLATION)
Q% ASCII \INTER\ ;INTERRUPT
Q$ ASCII \TTYIN\ ;TTYINT
ASCII \GCTIM\ ;GCTIME
ASCII \LOSEF\ ;LOSEF (LAP OBJECT STORAGE EFFICIENCY FACTOR)
ASCII \TERPR\ ;TERPRI (SUPPRESSION OF AUTO-TERPRI)
ASCII \←\ ;← (CAN PRIN1 USE ← FIXNUM SYNTAX)
Q% ASCII \PAGEP\ ;PAGEPAUSE
ASCII \TTYRE\ ;TTYREAD
ASCII \FEATU\ ;FEATURE
ASCII \NOFEA\ ;NOFEATURE
IFN USELESS, ASCII \ABBRE\ ;ABBREVIATE
ASCII \UUOLI\ ;UUOLINKS
ASCII \GCMAX\ ;GCMAX
10% ASCII \PDLMA\ ;PDLMAX
ASCII \GCSIZ\ ;GCSIZE
ASCII \LINMO\ ;LINMODE
ASCII \CRFIL\ ;CRFILE (CURRENT FILE)
ASCII \CRUNI\ ;CRUNIT (CURRENT UNIT)
ASCII \EVALH\ ;EVALHOOK (FOR MULTICS COMPATIBILITY)
Q$ ASCII \TTYSC\ ;TTYSCAN
Q$ ASCII \TTYCO\ ;TTYCONS
IFN NSTAT,[
IFN USELESS,[
IFN ITS,[
ASCII \WHO1\ ;WHO1 ;ITS WHO-LINE
ASCII \WHO2\ ;WHO2 ; DISPLAY
ASCII \WHO3\ ;WHO3 ; VARIABLES
Q$ ASCII \MAR\ ;MAR ;MAR BREAK FEATURE
Q$ ASCII \GCWHO\
] ;END OF IFN ITS
] ;END OF IFN USELESS
] ;END OF IFN NSTAT
IFN MOBIOF+QIO*ITS*USELESS,[
ASCII \FTV\ ;FTV (FAKE TV)
ASCII \FTVSI\ ;FTVSIZE
] ;END OF IFN MOBIOF+QIO*ITS*USELESS
LSSTBA==.-STBA ;END OF ENTRIES WHICH CAN BE SSTATUS'D
;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 2 *****
IFN MOBIOF+QIO*ITS*USELESS, ASCII \FTVTI\ ;FTVTITLE
ASCII \PURSI\ ;PURSIZE
ASCII \PDLSI\ ;PDLSIZE
ASCII \DAYTI\ ;DAYTIME
ASCII \DATE\ ;DATE
IFN USELESS, ASCII \DOW\ ;DOW (DAY OF WEEK)
10% ASCII \TTYSI\ ;TTYSIZE (HEIGHT . WIDTH)
ASCII \UNAME\ ;UNAME (USER NAME)
ASCII \XUNAM\
ASCII \JNAME\ ;JNAME (JOB NAME)
ASCII \XJNAM\
ASCII \LISPV\ ;LISPVERSION
ASCII \JCL\ ;JCL (JOB COMMAND LINE)
10% ASCII \HACTR\ ;HACTRN
ASCII \UDIR\ ;UDIR (USER DIRECTORY NAME)
ASCII \FXPDL\ ;FXPDL (FIXNUM PDL)
ASCII \FLPDL\ ;FLPDL (FLONUM PDL)
ASCII \PDL\ ;PDL (REG PDL)
ASCII \SPDL\ ;SPDL (SPECIAL PDL)
ASCII \BPSL\ ;BPSL (BINARY PROGRAM SPACE LOW)
ASCII \BPSH\ ;BPSH (BINARY PROGRAM SPACE HIGH)
ASCII \SEGLO\ ;SEGLOG (LOG2 OF SEGMENT SIZE)
ASCII \SYSTE\ ;SYSTEM (SYSTEM ATOM)
ASCII \TABSI\ ;TABSIZE
ASCII \SPCNA\ ;SPCNAMES (NAMES OF DATA SPACES)
ASCII \PDLNA\ ;PDLNAMES
ASCII \SPCSI\ ;SPCSIZE
ASCII \PDLRO\ ;PDLROOM
ASCII \MEMFR\ ;MEMFREE
ASCII \NEWLI\ ;NEWLINE
Q$ ASCII \FILEM\ ;FILEMODE
Q$ ASCII \TTYTY\ ;TTYTYPE
IFN NSTAT,[
IFN USELESS,[
IFN ITS,[
Q$ ASCII \ITS\ ;ITS
] ;END OF IFN ITS
] ;END OF IFN USELESS
] ;END OF IFN NSTAT
ASCII \STATU\ ;STATUS
ASCII \SSTAT\ ;SSTATUS
LSTBA==.-STBA
SUBTTL STATUS DISPATCH TABLES
IFE NSTAT,[
;;; ***** SSTATUS FUNCTION TABLE ***** MUST MATCH ASCII TABLE *****
STBSS:
Q% 20000,,IOC (FA1N&177)
140000,,SSMACRO (FA23)
224000,,RWG (FA1) ;DIVOV
10% 260000,,SSTTY (FA2)
10$ 260000,,FALSE (FA2) ;DEC-10 HAS NO (SSTATUS TTY)
0,,SSFREE (FA2) ;FREE
221000,,TLF (FA1) ;TOPLEVEL
221000,,BLF (FA1) ;BREAKLEVEL
20000,,UREAD (FA0234)
20000,,UWRITE (FA012)
220000,,SSPLSS (FA1) ;+
260000,,SSGCMIN (FA2)
160000,,SSSYNTA (FA2) ;SYNTAX
160000,,SSCHTRA (FA2) ;CHTRAN
260000,,SSINTERRUPT (FA2)
220000,,SSGCTIM (FA1) ;GCTIME
220000,,SSLOSEF (FA1)
220000,,SSTERPRI (FA1) ;TERPRI
220000,,SSLAP (FA1) ;←
Q% 224000,,SPP (FA1) ;PAGEPAUSE
220000,,SSTTYREAD (FA1)
0,,SSFEATURE (FA1)
0,,SSNOFEATURE (FA1)
IFN USELESS, 220000,,SABBREVIATE (FA1)
20000,,SSUUOLINKS (FA0)
260000,,SSGCMAX (FA2)
10% 260000,,SSPDLMAX (FA2)
260000,,SSGCSIZE (FA2)
10% 220000,,SSLINMODE (FA1)
10$ 224000,,LINMODE (FA1)
0,,SSCRFIL (FA2)
20000,,CRUNIT (FA012)
20000,,FALSE (FA1) ;EVALHOOK
IFN MOBIOF,[
20000,,SSFTV (FA0234)
220000,,SSFTVS (FA1)
] ;END OF IFN MOBIOF
LSST==.-STBSS
IFN LSST-LSSTBA, WARN [WRONG LENGTH SSTATUS TABLE]
;;; IFE NSTAT
;;; ***** STATUS FUNCTION TABLE ***** PART 1 (MATCHES STBSS) *****
STBS:
Q% 120000,,SIOC (FA1)
120000,,SMACRO (FA1)
30000,,RWG (FA0) ;DIVOV
10% 20000,,STTY (FA0)
10$ 30000,,VTRUTH (FA0) ;DEC-10 HAS NO (STATUS TTY)
0,,SFREE (FA1)
30000,,TLF (FA0) ;TOPLEVEL
30000,,BLF (FA0) ;BREAKLEVEL
20000,,SUREAD (FA0)
20000,,SUWRITE (FA0)
20000,,SPLSS (FA0) ;+
220000,,SGCMIN (FA1)
120000,,SSYNTAX (FA1)
120000,,SCHTRAN (FA1)
220000,,SINTERRUPT (FA1)
20000,,SGCTIM (FA0)
20000,,SLOSEF (FA0)
20000,,STERPRI (FA0) ;TERPRI
20000,,SLAP (FA0) ;←
30000,,SPP (FA0) ;PAGEPAUSE
20000,,STTYREAD (FA0)
20000,,SFEATURES (FA01)
20000,,SNOFEATURE (FA1)
IFN USELESS, 20000,,SABBREVIATE (FA0)
20000,,SUUOLINKS (FA0)
220000,,SGCMAX (FA1)
10% 220000,,SPDLMAX (FA1)
220000,,SGCSIZE (FA1)
30000,,LINMODE (FA0)
20000,,SCRFIL (FA0)
20000,,SCRUNIT (FA0)
20000,,FALSE (FA0) ;EVALHOOK
IFN MOBIOF,[
20000,,SFTV (FA0) ;FTV
22000,,MFTVBL (FA0) ;FTVSIZE
] ;END OF IFN MOBIOF
IFN .-STBS-LSSTBA, WARN [WRONG LENGTH STATUS TABLE PART 1]
;;; IFE NSTAT
;;; ***** STATUS FUNCTION TABLE ***** PART 2 (NON-SSTATUS ITEMS) *****
IFN MOBIOF, 20000,,SFTVTITLE (FA0) ;FTVTITLE
220000,,SPURSIZE (FA1)
220000,,SPDLSIZE (FA1)
20000,,STIME (FA0) ;DAYTIME
20000,,SDATE (FA0) ;DATE
IFN USELESS, 20000,,SDOW (FA0) ;DAY OF WEEK
10% 20000,,STTYSIZE (FA0) ;TTYSIZE
20000,,SUNAME (FA0) ;UNAME
20000,,SXUNAME (FA0)
20000,,SJNAME (FA0)
20000,,SXJNAME (FA0)
20000,,SLVRNO (FA0) ;LISPVERSION
10% 20000,,SJCL (FA0)
10$ 30000,,VNIL (FA0) ;DECSYSTEM-10 HAS NO JCL
10% 20000,,SDDTP (FA0) ;HACTRN
30000,,SUDIR (FA0) ;UDIR
22000,,FXC2 (FA0) ;FXPDL
22000,,FLC2 (FA0) ;FLPDL
22000,,C2 (FA0) ;PDL
22000,,SC2 (FA0) ;SPDL
22000,,BPSL (FA0) ;ORIGINAL FIRST OF BPS
22000,,BPSH (FA0) ;BPS HIGH
22000,,[SEGLOG] (FA0)
220000,,SSYSTEM (FA1)
22000,,IN10 (FA0) ;TABSIZE
30000,,[SPCNAMES] (FA0)
30000,,[PDLNAMES] (FA0)
220000,,SSPCSIZE (FA1)
220000,,SPDLROOM (FA1)
20000,,SMEMFREE (FA0)
22000,,IN0+↑M (FA0) ;NEWLINE
0,,SSSS (FA01) ;STATUS
0,,SSSSS (FA01) ;SSTATUS
IFN .-STBS-LSTBA, WARN [WRONG LENGTH STATUS TABLE PART 2]
] ;END OF IFE NSTAT
IFN NSTAT,[
;;; FORMAT <4.9-4.7> , <4.6-3.8> , <2.9-1.1>
.FORMAT 37,002231104103
RADIX 4
;;; MAGIC TABLE OF STATUS OPERATIONS
;;; 4.9-4.7 OPERATION TYPE
;;; 0 SUBR-TYPE FUNCTION
;;; 1 LSUBR-TYPE FUNCTION
;;; 2 SUBR-TYPE WITH CHAR FIRST ARG
;;; 3 LSUBR-TYPE WITH CHAR FIRST ARG
;;; 4 GET LISP VALUE
;;; 5 SET LISP VALUE
;;; 6 SET TO T-OR-NIL
;;; 7 GET FIXNUM VALUE
;;; 4.6-4.5 ARGUMENT 1 TYPE
;;; 0 NO MORE ARGS
;;; 1 QUOTED ARGUMENT
;;; 2 TAKE REST AS QUOTED LIST
;;; 3 EVALUATED ARGUMENT
;;; 4.4-4.3 ARGUMENT 2 TYPE
;;; 4.2-4.1 ARGUMENT 3 TYPE
;;; 3.9-3.8 ARGUMENT 4 TYPE
;;; 3.7-3.1 ARGS INFO
;;; IFN NSTAT
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** SSTATUS FUNCTION TABLE ***** MUST MATCH ASCII TABLE *****
STBSS:
Q% 0,2000,IOC (FA1N&177) ;IOC
3,1310,SSMACRO (FA23) ;MACRO
6,3000,RWG (FA1) ;DIVOV
10% Q% 0,3300,SSTTY (FA2) ;TTY
10% Q$ 1,3333,SSTTY (FA234) ;TTY
10$ Q% 0,3300,FALSE (FA2) ;TTY
10$ Q$ 1,3330,SSTTY (FA234) ;TTY
5,3000,TLF (FA1) ;TOPLEVEL
5,3000,BLF (FA1) ;BREAKLEVEL
0,2000,UREAD (FA0234) ;UREAD
0,2000,UWRITE (FA012) ;UWRITE
0,3000,SSPLSS (FA1) ;+
0,3300,SSGCMIN (FA2) ;GCMIN
2,1300,SSSYNTA (FA2) ;SYNTAX
2,1300,SSCHTRA (FA2) ;CHTRAN
Q% 0,3300,SSINTERRUPT (FA2) ;INTERRUPT
Q$ 1,3330,SSTTYINT (FA23) ;TTYINT
0,3000,SSGCTIM (FA1) ;GCTIME
0,3000,SSLOSEF (FA1) ;LOSEF
Q% 0,3000,SSTERPRI (FA1) ;TERPRI
Q$ 1,3300,SSTERPRI (FA12) ;TERPRI
0,3000,SSLAP (FA1) ;←
Q% 5,3000,SPP (FA1) ;PAGEPAUSE
Q% 0,3000,SSTTYREAD (FA1) ;TTYREAD
Q$ 1,3300,SSTTYREAD (FA12) ;TTYREAD
0,1000,SSFEATURE (FA1) ;FEATURE
0,1000,SSNOFEATURE (FA1) ;NOFEATURE
IFN USELESS, 0,3000,SSABBREVIATE (FA1) ;ABBREVIATE
0,0000,SSUUOLINKS (FA0) ;UUOLINKS
0,3300,SSGCMAX (FA2) ;GCMAX
10% 0,3300,SSPDLMAX (FA2) ;PDLMAX
0,3300,SSGCSIZE (FA2) ;GCSIZE
10% 0,3000,SSLINMODE (FA1) ;LINMODE
10$ 5,3000,LINMODE (FA1) ;LINMODE
0,2000,SSCRFIL (FA2) ;CRFILE
0,2000,CRUNIT (FA012) ;CRUNIT
0,3000,FALSE (FA1) ;EVALHOOK
Q$ 1,3300,SSTTYSCAN (FA12) ;TTYSCAN
Q$ 0,3300,SSTTYCONS (FA2) ;TTYCONS
IFN USELESS,[
IFN ITS,[
0,3333,SSWHO1 (FA4) ;WHO1
0,3000,SSWHO2 (FA1) ;WHO2
0,3000,SSWHO3 (FA1) ;WHO3
Q$ 0,3300,SSMAR (FA2) ;MAR
Q$ 0,3000,SSGCWHO (FA1) ;GCWHO
] ;END OF IFN ITS
] ;END OF IFN USELESS
IFN MOBIOF+QIO*ITS*USELESS,[
0,2000,SSFTV (FA0234) ;FTV
0,3000,SSFTVS (FA1) ;FTVSIZE
] ;END OF IFN MOBIOF+QIO*ITS*USELESS
LSST==.-STBSS
IFN LSST-LSSTBA, WARN [WRONG LENGTH SSTATUS TABLE]
;;; IFN NSTAT
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** STATUS FUNCTION TABLE ***** PART 1 (MATCHES STBSS) *****
STBS:
Q% 0,1000,SIOC (FA1) ;IOC
2,1000,SMACRO (FA1) ;MACRO
4,0000,RWG (FA0) ;DIVOV
10% Q% 0,0000,STTY (FA0) ;TTY
10% Q$ 1,3000,STTY (FA01) ;TTY
10$ 4,0000,NIL (FA0) ;DEC-10 HAS NO (STATUS TTY)
4,0000,TLF (FA0) ;TOPLEVEL
4,0000,BLF (FA0) ;BREAKLEVEL
0,0000,SUREAD (FA0) ;UREAD
0,0000,SUWRITE (FA0) ;UWRITE
0,0000,SPLSS (FA0) ;+
0,3000,SGCMIN (FA1) ;GCMIN
2,1000,SSYNTAX (FA1) ;SYNTAX
2,1000,SCHTRAN (FA1) ;CHTRAN
Q% 0,3000,SINTERRUPT (FA1) ;INTERRUPT
Q$ 1,3300,STTYINT (FA12) ;TTYINT
0,0000,SGCTIM (FA0) ;GCTIM
0,0000,SLOSEF (FA0) ;LOSEF
Q% 0,0000,STERPRI (FA0) ;TERPRI
Q$ 1,3000,STERPRI (FA01) ;TERPRI
0,0000,SLAP (FA0) ;←
Q% 4,0000,SPP (FA0) ;PAGEPAUSE
Q% 0,0000,STTYREAD (FA0) ;TTYREAD
Q$ 1,3000,STTYREAD (FA01) ;TTYREAD
0,2000,SFEATURES (FA01) ;FEATURES
0,2000,SNOFEATURE (FA1) ;NOFEATURE
IFN USELESS, 0,0000,SABBREVIATE (FA0) ;ABBREVIATE
0,0000,SUUOLINKS (FA0) ;UUOLINKS
0,3000,SGCMAX (FA1) ;GCMAX
10% 0,3000,SPDLMAX (FA1) ;PDLMAX
0,3000,SGCSIZE (FA1) ;GCSIZE
Q% 4,0000,LINMODE (FA0) ;LINMODE
Q$ 1,3000,SLINMODE (FA01) ;LINMODE
0,0000,SCRFIL (FA0) ;CRFILE
0,0000,SCRUNIT (FA0) ;CRUNIT
0,0000,FALSE (FA0) ;EVALHOOK
Q$ 1,3000,STTYSCAN (FA01) ;TTYSCAN
Q$ 0,3000,STTYCONS (FA1) ;TTYCONS
IFN USELESS,[
IFN ITS,[
0,0000,SWHO1 (FA0) ;WHO1
0,0000,SWHO2 (FA0) ;WHO2
0,0000,SWHO3 (FA0) ;WHO3
Q$ 0,0000,SMAR (FA0) ;MAR
Q$ 7,0000,GCWHO (FA0) ;GCWHO
] ;END OF IFN ITS
] ;END OF IFN USELESS
IFN MOBIOF,[
0,0000,SFTV (FA0) ;FTV
7,0000,MFTVBL (FA0) ;FTVSIZE
] ;END OF IFN MOBIOF
IFN QIO*ITS*USELESS,[
0,0000,SFTV (FA0) ;FTV
0,0000,SFTVSIZE (FA0) ;FTVSIZE
] ;END OF QIO*ITS*USELESS
IFN .-STBS-LSSTBA, WARN [WRONG LENGTH STATUS TABLE PART 1]
;;; IFN NSTAT
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** STATUS FUNCTION TABLE ***** PART 2 (NON-SSTATUS ITEMS) *****
IFN MOBIOF+QIO*ITS*USELESS,[
0,0000,SFTVTITLE (FA0) ;FTVTITLE
] ;END OF IFN MOBIOF+QIO*ITS*USELESS
0,3000,SPURSIZE (FA1) ;PURSIZE
0,3000,SPDLSIZE (FA1) ;PDLSIZE
0,0000,STIME (FA0) ;DAYTIME
0,0000,SDATE (FA0) ;DATE
IFN USELESS, 0,0000,SDOW (FA0) ;DOW (DAY OF WEEK)
10% Q% 0,0000,STTYSIZE (FA0) ;TTYSIZE
10% Q$ 1,3000,STTYSIZE (FA01) ;TTYSIZE
0,0000,SUNAME (FA0) ;UNAME
0,0000,SXUNAME (FA0)
0,0000,SJNAME (FA0) ;JNAME
0,0000,SXJNAME (FA0)
0,0000,SLVRNO (FA0) ;LISPVERSION
10% 0,0000,SJCL (FA0) ;JCL
10$ 4,0000,VNIL (FA0) ;DECSYSTEM-10 HAS NO JCL
10% 0,0000,SDDTP (FA0) ;HACTRN
4,0000,SUDIR (FA0) ;UDIR
7,0000,FXC2 (FA0) ;FXPDL
7,0000,FLC2 (FA0) ;FLPDL
7,0000,C2 (FA0) ;PDL
7,0000,SC2 (FA0) ;SPDL
7,0000,BPSL (FA0) ;BPSL (ORIGINAL BPS LOW)
7,0000,BPSH (FA0) ;BPS HIGH
7,0000,[SEGLOG] (FA0) ;SEGLOG
0,3000,SSYSTEM (FA1) ;SYSTEM
7,0000,IN10 (FA0) ;TABSIZE
4,0000,[SPCNAMES] (FA0) ;SPCNAMES
4,0000,[PDLNAMES] (FA0) ;PDLNAMES
0,3000,SSPCSIZE (FA1) ;SPCSIZE
0,3000,SPDLROOM (FA1) ;PDLROOM
0,0000,SMEMFREE (FA0) ;MEMFREE
7,0000,IN0+↑M (FA0) ;NEWLINE
Q$ 0,3000,SFILEMODE (FA1) ;FILEMODE
Q$ 1,3000,STTYTYPE (FA01) ;TTYTYPE
IFN USELESS,[
IFN ITS,[
Q$ 0,0000,SITS (FA0) ;ITS
] ;END OF IFN ITS
] ;END OF IFN USELESS
1,1000,SSSS (FA01) ;STATUS
1,1000,SSSSS (FA01) ;SSTATUS
IFN .-STBS-LSTBA, WARN [WRONG LENGTH STATUS TABLE PART 2]
RADIX 8
.FORMAT 37,0 ;MAKE FORMAT 37 ILLEGAL AGAIN
] ;END OF IFN NSTAT
;;@ END OF STATUS 93
SUBTTL CURSORPOS FUNCTION
IFN USELESS*ITS,[
IFE QIO,[
CURSORPOS: JSP TT,LWNACK ;LSUBR (0 . 2) - HACK CURSOR
LA012,,QCURSORPOS ; FOR CHARACTER DISPLAYS
JSP R,PDLA2(T)
SKIPN TTYOFF ;↑W DISABLES, OF COURSE
SKIPN TTYDISP ;USELESS ON PRINTING TERMINALS
JRST FALSE
JUMPE T,CRSRP1 ;0 ARGS - GET POSITION
AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (↑P CODES)
PUSH P,B ;2 ARGS - SET POSITION (↑P H, ↑P V)
MOVSI R,(ASCII \⊂V\) ;SET VERTICAL POSITION
PUSHJ P,CRSRP5
MOVSI R,(ASCII \⊂H\) ;SET HORIZONTAL POSITION
POP P,A
CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE
JSP T,FXNV1
SKIPGE TT
SETZ TT,
CAILE TT,167 ;NOR ARG ABOVE 167
MOVEI TT,167
ADDI TT,10 ;ADD 10 FOR ↑P CROCK
DPB TT,[170700,,R]
CRSRP7: MOVEI D,R
PUSHJ P,SRNTYP ;SHOVE OUT ↑P COMMAND
JRST TRUE
CRSRP3: JSP T,SPATOM ;IF SYMBOL, USE FIRST CHAR
JRST CRSRP4
JSP T,CHNV1
JRST CRSRP6
CRSRP4: JSP T,FXNV1 ;ELSE BETTER BE FIXNUM
CRSRP6: MOVEI R,(TT)
TRC TT,100
TDNE TT,[-40]
JRST CRSRP2
MOVE TT,GCBT(TT)
TDNN TT,CRSRP9
JRST CRSRP2
LSH R,26 ;IF LEGAL, PUT A ↑P IN FRONT
TLO R,<↑P>←13 ; AND HAND IT OFF TO SRNTYP
MOVEI D,R
JRST CRSRP7
CRSRP9:
ZZZ==100 ;[CODE FOR "↑P ]" (BEWARE BRACKETS)
IRPC X,,[ABCDEFKLMNPTUXZ]
ZZZ==ZZZ\<SETZ←-<"X&37>>
TERMIN
ZZZ ;BITS SPECIFYING VALID ↑P CODES
EXPUNGE ZZZ ;NOTE: H AND V NOT VALID HERE!
CRSRP1: .CALL RCPSBK ;GET CURRENT CURSOR POSITION
.VALUE
MOVEI TT,(D) ;CONS THEM UP FOR LOSER
JSP T,FIX1A
MOVEI B,(A)
HLRZ TT,D
JSP T,FIX1A
JRST CONS
] ;END OF IFE QIO
;;; IFN USELESS*ITS
IFN QIO,[
CURSORPOS: MOVEI D,QCURSORPOS ;LSUBR (0 . 3)
CAMGE T,XC-3 ;MORE THAN THREE ARGS LOSES
JRST WNALOSE
JUMPE T,CRSRP0 ;IF NO ARGS, IS FOR DEFAULT TTY
CRSRPS: SKIPN AR1,(P) ;ELSE LAST ARG MAY BE TTY FILE ARRAY
JRST CRSRN
MOVEI TT,(AR1)
LSH TT,-SEGLOG
SKIPGE ST(TT)
JRST CRSRMP
CAIN AR1,TRUTH ;LAST ARG = T
HRRZ AR1,V%TYO ; MEANS THE DEFAULT TTY
CRSR10: CAMN T,XC-3 ;FOR THREE ARGS MUST HAVE A FILE ARRAY
JRST CRSRP8
JSP TT,XFILEP ;FOR ONE OR TWO ARGS MAY OR MAY
JRST CRSRP0 ; NOT HAVE A FILE ARRAY
CRSRP8: SUB P,R70+1 ;IF WE HAVE ONE, IT MUST
PUSH FXP,T ; BE A BONA FIDE TTY OUTPUT FILE
PUSHJ P,TOFLOK
UNLOCKI
POP FXP,T
AOSA T
CRSRP0: HRRO AR1,V%TYO
JSP R,PDLA2(T)
MOVEI TT,F.MODE
MOVE D,@TTSAR(AR1)
SKIPGE AR1 ;IF FILE NOT EXPLICITLY GIVEN
SKIPN TTYOFF ; THEN ↑W NON-NIL => RETURN NIL
TLNN D,FBT<CP> ;RETURN NIL IF NOT DISPLAY
JRST FALSE
JUMPE T,CRSRP1 ;0 ARGS - GET POSITION
AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (↑P CODES)
SKOTT A,FX ;2 ARGS
JRST CRSR11
MOVEI D,"V ;SET VERTICAL POSITION
PUSHJ P,CRSRP5
CRSR20: MOVEI D,"H ;SET HORIZONTAL POSITION
MOVEI A,(B)
CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE
JSP T,FXNV1
SKIPGE TT
SETZ TT, ;NEGATIVE ARG NOT ALLOWED
CAILE TT,167 ;NOR ARG ABOVE 167
MOVEI TT,167
HRLI D,10(TT) ;ADD MAGIC 10 TO AMOUNT FOR ↑P
CRSRP7: PUSHJ P,CNPCOD
JRST TRUE
CRSRP3: JSP T,SPATOM ;IF SYMBOL, USE FIRST CHAR
JRST CRSRP4
PUSHJ P,CRSR40
JRST CRSRP6
CRSR40: JSP T,CHNV1
CAIL TT,140
SUBI TT,40 ;CONVERT TO UPPER CASE
POPJ P,
CRSRP4: JSP T,FXNV1 ;ELSE BETTER BE FIXNUM
CRSRP6: MOVEI D,(TT)
TRC TT,100
TDNE TT,[-40]
JRST CRSRP2
MOVE TT,GCBT(TT)
TDNN TT,CRSRP9
JRST CRSRP2
JRST CRSRP7
CRSRP9:
ZZZ==100 ;[CODE FOR "↑P ]" (BEWARE BRACKETS)
IRPC X,,[ABCDEFKLMNTUXZ]
ZZZ==ZZZ\<SETZ←-<"X&37>>
TERMIN
ZZZ ;BITS SPECIFYING VALID ↑P CODES
EXPUNGE ZZZ ;NOTE: H AND V NOT VALID HERE!
CRSR11: JUMPE A,CRSR20
JSP T,SPATOM
JRST CRSR12
PUSHJ P,CRSR40
JSP T,FXNV2
SKIPGE D
SETZ D,
CAIE TT,"H
CAIN TT,"V
JRST CRSR13
CAIN TT,"I
JRST CRSR14
CRSR12: WTA [BAD CURSOR CODE - CURSORPOS!]
JRST CRSR11
CRSR13: CAILE D,167
MOVEI D,167
ADDI D,10 ;H AND V RANDOMLY WANT 10 ADDED
CRSR14: MOVSI D,400000(D) .SEE CNPCD1 ;KEEP LH FROM BEING ZERO
HRRI D,(TT)
JRST CRSRP7
CRSRP1: PUSHJ P,FORCE1
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
MOVEI TT,F.CHAN
.CALL RCPOS ;GET CURRENT CURSOR POSITION
.VALUE
TLNE F,FBT<EC> ;GET ECHO MODE POSITION
MOVE D,R ; IF FILE IS FOR ECHO AREA
MOVEI TT,(D) ;CONS THEM UP FOR LOSER
JSP T,FIX1A
MOVEI B,(A)
HLRZ TT,D
JSP T,FIX1A
JRST CONS
CRSRMP: PUSH FXP,T
CRSRM1: HLRZ A,@(P)
MOVE T,(FXP)
MOVEI TT,(T)
ADDI TT,(P)
PUSH P,1(TT)
TRNE T,1
PUSH P,2(TT)
PUSH P,A
PUSHJ P,CRSRPS
HRRZ A,@(P)
MOVEM A,(P)
JUMPN A,CRSRM1
POP FXP,T
CRSRN: MOVEI A,TRUTH
JRST PROGN1
] ;END OF IFN QIO
] ;END OF IFN USELESS*ITS
IFN FUNAFL,[
SUBTTL RANDOM ROUTINES TO HANDLE A PSEUDO ALIST
%%FUNCTION: MOVEI D,Q%%FUNCTION
JUMPE A,WNAFOSE
HRRZ C,(A)
JUMPN C,.FUNC1
HLRZ B,(A) ;HALF-ASSED FUNARG BINDING
HRROI TT,(SP) ;ONE LH AS GOOD AS ANOTHER
JSP T,FIX1A
PUSHJ P,XCONS
.FUNC4: MOVEI B,QFUNARG
JRST XCONS
.FUNC1: HLRZ AR2A,(A)
HLRZ AR1,(C)
HRRZ C,(C)
JUMPN C,WNAFOSE
.FUNC2: JUMPE AR1,.FUNC3
HLRZ A,(AR1)
JSP T,SPATOM
JSP T,PNGE1
HLRZ B,(A)
HLRZ B,@(B)
PUSHJ P,CONS
MOVEI B,(C)
PUSHJ P,CONS
HRRZ AR1,(AR1)
JRST .FUNC2
.FUNC3: MOVEI A,(C)
MOVEI B,TRUTH
PUSHJ P,NRECONC
MOVEI B,(AR2A)
PUSHJ P,CONS
JRST .FUNC4
AEVAL: SKIPE A,(P) ;PURPOSELY CRIPPLING POWER OF ALIST
JSP T,FXNV1 ; ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;EVAL WITH AN ALIST
SUB P,R70+1
POP P,A
SKIPE T ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
POP FXP,T ;SKIP 1 RETURN
JRST 1(T)
;;; IFN FUNAFL
;;; ALIST CREATES AN ENVIRONMENT AS SPECIFIED BY A GIVEN A-LIST.
;;; AN A-LIST MAY BE:
;;; [1] NIL, MEANING THE TOP-LEVEL ENVIRONMENT.
;;; [2] T, MEANING THE CURRENT ENVIRONMENT (SEE [4]).
;;; [3] A FIXNUM REPRESENTING A SPECPDL POINTER, AS
;;; RETURNED BY THE EVALFRAME FUNCTION AS THE FOURTH
;;; ITEM. THIS INDICATES THE ENVIRONMENT AS OF
;;; THE SPECIFIED FRAME.
;;; [4] ((<SYMBOL> . <VALUE>) . <A-LIST>)
;;; THAT IS, ONTO ONE OF THE OTHER THREE KINDS OF A-LIST
;;; ONE MAY CONS ADDITIONAL VARIABLE-VALUE PAIRS IN
;;; THE USUAL MANNER. THIS IS A "TRUE A-LIST".
;;; THIS ENVIRONMENT IS CREATED BY REBINDING ALL VARIABLES
;;; WHICH HAVE BEEN BOUND SINCE THEN BACK TO THEIR OLD VALUES,
;;; OR TO THE VALUES SPECIFIED BY THE TRUE A-LIST. IF A GIVEN
;;; VARIABLE WAS BOUND SEVERAL TIMES, ONLY ONE REBINDING IS DONE
;;; TO RECREATE THE OLD ENVIRONMENT. THIS IS DONE BY USING THE
;;; LEFT HALF OF A VALUE CELL TO INDICATE WHETHER OR NOT IT
;;; HAS ALREADY BEEN REBOUND. THIS HAS THE CONSEQUENCE THAT
;;; NOQUIT MUST BE TURNED ON DURING THIS OPERATION.
;;; EITHER ONE OR TWO SPECPDL BLOCKS ARE PUSHED, THE SECOND ONE
;;; BEING NECESSARY IF ANY TRUE A-LIST IS GIVEN. THERE ARE FOUR
;;; STEPS TO THE PROCESS:
;;; [1] CHECK ARGUMENT THOROUGHLY FOR ERRORS. IF A TRUE
;;; A-LIST IS GIVEN, ALL SYMBOLS ON THE A-LIST ARE GIVEN
;;; VALUE CELLS IF THEY DON'T HAVE ANY ALREADY.
;;; [2] TURN ON NOQUIT. IF A TRUE A-LIST IS GIVEN, BIND ALL
;;; THE SYMBOLS AS SPECIFIED, MARKING THE VALUE CELLS
;;; AS THEY ARE BOUND, AND NEVER BINDING A SYMBOL TWICE.
;;; WHEN DONE, PUSH THE TRUE A-LIST ONTO THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [3] SCAN THE SPECPDL FROM THE POINT SPECIFIED BY THE
;;; SPECPDL POINTER (FROM THE BOTTOM IF NIL), AND BIND
;;; ALL VALUES CELLS SEEN BACK TO THEIR OLD VALUES,
;;; MARKING THEM AS THEY ARE BOUND, NEVER BINDING ONE
;;; TWICE. WHEN DONE, PUSH A POINTER ON THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [4] SCAN BACK OVER ALL THE ITEMS PUSHED IN STEPS 2
;;; AND 3, RESTORING THE LAFT HALVES OF ALL THE VALUE
;;; CELLS. TURN OFF NOQUIT AND CHECK FOR INTERRUPTS.
;;; ON RETURN, A-LIST LEAVES T NON-ZERO IFF TWO BIND BLOCKS
;;; WERE PUSHED. IT IS UP TO THE CALLER TO MAKE SURE THAT THE
;;; BLOCK(S) ARE UNBOUND CORRECTLY WITH AUNBIND.
;;; NOTE THAT ERRPOP CAN RECOGNIZE THESE SPECIAL BIND BLOCKS AND
;;; CALL AUNBIND TO UNBIND THEM. THIS IS BECAUSE THE LAST WORD
;;; PUSHED HAS ZERO IN THE LEFT HALF.
ALIST: SKIPN C,-1(P) ;MAKE COPY OF ENVIRONMENT GIVEN A-LIST
ALST1: JUMPE C,ALST3 ;STEP 1 - ERROR CHECKING
CAIN C,TRUTH
JRST ALST3 ;T AND NIL ARE VALID A-LISTS
SKOTT C,LS
JRST ALST2 ;NOPE - GO CHECK IT OUT
HLRZ AR1,(C) ;YUP - CHECK ITS CAR
HRRZ C,(C)
SKOTT AR1,LS
JRST ALST0
HLRZ A,(AR1)
SKOTT A,SY
JRST ALST0
CAIN A,TRUTH
JRST ALST0
HLRZ AR1,(A)
HRRZ B,(AR1)
MOVEI AR1,QUNBOUND
CAIN B,SUNBOUND
JSP T,.SET1
JRST ALST1
;;; IFN FUNAFL
ALST2: TLNN TT,FX ; - DARN WELL BETTER BE A FIXNUM
JRST ALST0
HRRZ TT,(C) ;MUST BE A VALID SPECPDL POINTER
CAML TT,ZSC2
CAILE TT,(SP)
JRST ALST0
ALST3: HLLOS NOQUIT ;TURN ON NOQUIT - MUSTN'T INTERRUPT
HLLOS MUNGP ;ABOUT TO MUNG VALUE CELLS!
MOVEM SP,SPSV ;STEP 2 - PUSH BLOCK FOR TRUE A-LIST
SETZ T, ;T WILL BECOME NON-ZERO IF TRUE
SKIPN C,-1(P) ; A-LIST IS PRESENT AT ALL
ALST3A: JUMPE C,ALST4 ;NIL FOUND
CAIN C,TRUTH
JRST ALST7 ;T FOUND
SKOTT C,LS
JRST ALST4A ;FIXNUM FOUND
HLRZ B,(C)
HRRZ C,(C)
HLRZ A,(B) ;A HAS ATOMIC SYMBOL
HRRZ AR1,(B) ;AR1 HAS ASSOCIATED VALUE
HLRZ B,(A)
HRRZ A,(B)
SKIPGE AR2A,(A) ;SKIP UNLESS VALUE CELL MARKED
JRST ALST3A ;VALUE CELL ALREADY REBOUND
HRLI AR2A,(A) ;PUSH <VALUE CELL,,CURRENT VALUE>
PUSH SP,AR2A ; ONTO SPECPDL; THEN INSTALL
HRROM AR1,(A) ; VALUE FROM ENVIRONMENT, MARKING CELL
AOJA T,ALST3A ;T NON-ZERO => WE PUSHED SOMETHING
ALST4: MOVEI C,SC2 ;NIL => TOP LEVEL ENVIRONMENT
ALST4A: HRRZ C,(C) ;FIXNUM => SPECIFIED ENVIRONMENT
HRRZ B,SPSV
JUMPE T,ALST4C ;IF ANYTHING PUSHED, START NEW BLOCK
PUSH SP,-1(P) ;LEFT HALF BETTER BE ZERO!
PUSH SP,SPSV ;FINISH OFF BLOCK FOR TRUE A-LIST
MOVEM SP,SPSV ;START NEW BLOCK FOR FUNARG POINTER
ALST4C: MOVEI TT,(C) ;STEP 3 - SCAN SPECPDL FROM ENVIRONMENT
ALST5: CAIN TT,(B) ; BACK UP TO POINT WHEN ALIST CALLED
JRST ALST6
HRRZ AR1,(TT) ;GET VALUE FROM SPECPDL
CAMGE AR1,ZSC2 ;IGNORE SPECPDL POINTERS
JRST ALST5A
CAIGE AR1,(SP)
AOJA TT,ALST5
ALST5A: HLRZ A,(TT) ;GET VALUE CELL FROM SLOT
JUMPE A,AL5AB ;IGNORE FROBS ALIST PUSHES!
SKIPGE AR2A,(A) ;IGNORE MARKED VALUE CELLS
AL5AB: AOJA TT,ALST5
HRLI AR2A,(A) ;ELSE PUSH AS BEFORE
PUSH SP,AR2A
HRROM AR1,(A)
AOJA TT,ALST5
;;; IFN FUNAFL
ALST7: HRRZ C,-1(P) ;T => CURRENT ENVIRONMENT
SETZ T, ;ONLY ONE BLOCK PUSHED
HRRZ B,SPSV
ALST6: PUSH SP,C ;STEP 4 - RESTORE VALUE CELLS
ALST6A: CAIN B,(SP)
JRST ALST7A
HLRZ A,(B)
JUMPE A,ALST6B
CAMGE A,ZSC2
HRRZS (A)
ALST6B: AOJA B,ALST6A
ALST7A: PUSH SP,SPSV ;CLOSE BIND BLOCK
HLLZS MUNGP ;VALUE CELLS UNMUNGED
JRST CZECHI ;ALL DONE - CHECK INTERRUPTS
;;; AUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST.
;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF
;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST,
;;; CLOBBERING CURRENT VALUES FROM VALUE CELLS INTO SPECPDL
;;; SLOTS OR A-LIST SLOTS AS APPROPRIATE, SO THAT ANY SETQ'S
;;; DONE IN THE CREATED COPY OF THE ENVIRONMENT WILL BE
;;; REFLECTED IN THE ORIGINAL ENVIRONMENT.
AUNBIND: POP SP,T
AUNBN0: MOVEM TT,UNBND3
MOVEM D,AUNBD
MOVEM R,AUNBR
MOVEM F,AUNBF
MOVEI F,1(T)
HRRZ R,(SP)
CAMGE R,ZSC2
JRST AUNBN4
AUNBN1: CAIN F,(SP) ;CLOBBER SETQ'S BACK INTO SPECPDL
JRST AUNBN3
HLRZ D,(F)
AUNBN2: HLRZ TT,(R)
CAIE TT,(D)
AOJA R,AUNBN2
HRRZ TT,(TT)
HRRM TT,(R)
AOJA F,AUNBN1
AUNBN3: MOVE F,AUNBF
MOVE R,AUNBR
MOVE D,AUNBD
SUB SP,R70+1
JRST UNBND0
AUNBN4: ;CLOBBER SETQ'S BACK INTO TRUE A-LIST
AUNBN5: CAIN F,(SP)
JRST AUNBN3
HLRZ D,(F)
JRST AUNBN7
AUNBN6: HRRZ R,(R)
AUNBN7: HLRZ TT,(R)
HLRZ TT,(TT)
HLRZ TT,(TT)
HRRZ TT,(TT)
CAIE TT,(D)
JRST AUNBN6
HLRZ TT,(R)
HRRZ D,(D)
HRRM D,(TT)
AOJA F,AUNBN5
;;; IFN FUNAFL
IAP4A: MOVEM TT,R ;AT THIS POINT, WE MAKE UP AN
HRROI TT,(SP)
JSP T,FIX1A
PUSH P,A
MOVE TT,R
MOVNI R,2
MOVNI T,1
JRST IAP5
APFNG: HRRZ A,(B) ;APPLY FUNARG
HLRZ B,(B)
HRRM B,(C)
PUSH P,A
MOVEM T,APFNG1
PUSHJ P,ALIST
PUSH P,.
HRROI TT,-2(P)
MOVE D,APFNG1
POP TT,2(TT)
AOJLE D,.-1
CAUNBIND: MOVEI D,AUNBIND
MOVEM D,2(TT)
SKIPN T
MOVEI D,CPOPJ
MOVEM D,1(TT)
MOVE T,APFNG1
JRST IAPPLY
APLBL: HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
MOVEM SP,SPSV ;APPLY LABEL EXPRESSION
PUSHJ P,BIND
PUSHJ P,ABIND3
MOVEI A,APLBL1
EXCH A,-1(C)
HLLM A,-1(C)
PUSH FXP,A
JRST IAPPLY
APLBL1: PUSHJ P,UNBIND
POPJ FXP,
] ;END OF IFN FUNAFL
SUBTTL LISTIFY, PNPUT, AND PNGET
LISTIFY: SKIPN R,ARGLOC
JRST LFYER
JSP T,FXNV1 ;LISTIFY UP N ARGS FOR AN LSUBR
MOVM D,TT
CAMLE D,@ARGNUM
JRST LFY0
JUMPGE TT,LFY3
ADD R,@ARGNUM
SUBI R,(D)
LFY3: HRLOI TT,(D) ;SEE HAKMEM (A.I. MEMO 239) ITEM 156
EQVI TT,(R) ;TT GETS <-N-1>,,<CONTENTS OF ARGLOC>
AOBJP TT,FALSE ;ZERO ARGS
PUSH P,R70
MOVEI R,(P) ;T HOLDS LAST POINTER
LFY1: MOVE A,(TT) ;GET ARG
JSP T,PDLNMK
PUSHJ P,NCONS
HRRM A,(R) ;CLOBBER ONTO END OF LIST
MOVEI R,(A) ;ADVANCE LAST POINTER
AOBJN TT,LFY1
JRST POPAJ
PNPUT: JUMPE B,SYCONS
PUSH P,A
SETZM LPNF
JRST INTRN1
$PNGET: PUSHJ P,PNGET
MOVE C,A
JSP T,FXNV2
MOVEI B,0
CAIN TT+1,7
POPJ P,
CAIE TT+1,6
LERR [SIXBIT \FEATURE NOT YET IMPLEMENTED - PNGET!\]
TDZA D,D
$PNG.R: PUSHJ P,CONSFX
SETZ TT,
MOVE R,[440600,,TT]
$PNG3: TLNN D,760000
JRST $PNG.D
$PNG3A: TLNN R,740000
JRST $PNG.R
$PNG4: ILDB T,D ;GET NEXT ASCII BYTE
JUMPE T,$PNGX
ADDI T,40 ;CONVERT, AND STORE
IDPB T,R
JRST $PNG3
$PNG.D: JUMPE C,$PNGX
HLRZ F,(C) ;CONSTRUCT WORD OF ASCII, AND BPTR THERETO
MOVE F,(F)
HRRZ C,(C)
MOVE D,[440700,,F]
JRST $PNG3A
$PNGX: JUMPE TT,.+2
PUSHJ P,CONSFX
JRST NREVERSE
SUBTTL EXAMINE, DEPOSIT, MAKNUM, MUNKAM
DEPOSIT: EXCH A,B
JSP T,FXNV2
JSP T,FLTSKP
JFCL
MOVEM TT,(TT+1)
JRST TRUE
EXAMINE: PUSH P,CFIX1
JSP T,FXNV1
MOVE TT,(TT)
POPJ P,
MAKNUM: MOVEI TT,(A)
JRST FIX1
MUNKAM: JSP T,FXNV1
MOVEI A,(TT)
POPJ P,
SUBTTL SLEEP, LISTEN, ALARMCLOCK
; PUTCODE [SLEEP/LISTEN/ALARM]61,TOP,CUS
$SLEEP: JSP T,FLTSKP
10% JSP T,M30.
10% FMPR TT,[30.0]
10$ JRST .+2
JSP T,IFIX
10% .SLEEP TT, ;SLEEP FOR <TT> 30TH'S OF A SECOND
10$ SLEEP TT, ;SLEEP FOR <TT> SECONDS
JRST TRUE
IFN SAIL,[
CLKINT=717000,,0
IMSKST=721000,,0
IMSKCL=722000,,0
UWAIT=047000,,400034
DEBREAK=047000,,400035
INTUUO=723000,,0
ALARMCLOCK: EXCH A,B
SKIPN @A
JRST SALCK0
MOVEI TT,SAILJOB
MOVEM TT,71
MOVEM B,ACLKTYP
CAIE B,Q$RUNTIME
JRST ALCK1
JSP T,FLTSKP ;RUN TIME IN MICROSECONDS,
JRST .+2 ; ACCURATE TO 4. USEC JIFFIES
JSP T,IFIX
IDIVI TT,1000. ;RUN TIME IN MILLISECONDS
PUSH TT,FXP
SETZ TT,
RUNTIME TT,
ADD TT,@FXP ; RUNTIME WHEN CLOCK SHOULD GO OFF
SUBI FXP,[1,,1]
MOVEM TT,SAIALK
MOVEI TT, SAILINT ;THIS IS WHERE INTERRUPT ROUTINE IS
HRRZM TT,SAILJOB+2
IMSKST SAINTER ;MASK THEM ON
CLKINT 36 ;SET INTERVAL
ALCK4: JRST TRUE
ALCK1: CAIE B,QTIME
JRST ALCK0
JSP T,FLTSKP ;REAL TIME IN SECONDS,
JSP T,M6. ; ACCURATE TO SIXTHS
FMPRI TT,(6.0)
JSP T,IFIX
MOVEM TT,SAIALK ;NUMBER OF CLKINTS TO GO
MOVEI TT,S2ILIN2
HRRZM TT,SAILJOB+2
IMSKST SAINTER ;MASK ON
CLKINT 12 ;ENABLE & GO
JRST ALCK4
SALCK0: IMSKCL SAINTER ;UNMASK
CLKINT 0 ;DISABLE
JRST FALSE
M6.: IMULI TT,6. ;NOTE: DOUBLE SKIP RETURN
JRST 2(T)
] ;END OF IFN SAIL
IFN ITS,[
ALARMCLOCK: EXCH A,B
CAIE B,Q$RUNTIME
JRST ALCK1
JSP T,FLTSKP ;RUN TIME IN MICROSECONDS,
JRST .+2 ; ACCURATE TO 4. USEC JIFFIES
JSP T,IFIX
ASH TT,-2
.SUSET [.SRTMR,,TT]
ALCK4: JUMPL TT,FALSE
JRST TRUE
ALCK1: CAIE B,QTIME
JRST ALCK0
JSP T,FLTSKP ;REAL TIME IN SECONDS,
JSP T,M30. ; ACCURATE TO 30TH'S
FMPRI TT,(30.0)
JSP T,IFIX
LSH TT,1
MOVSI R,400000
JUMPL TT,ALCK2
JUMPN TT,ALCK7
MOVEI TT,1 ;IF 0 SPECIFIED, USE 1/30 SECOND
ALCK7: MOVE R,[600000,,TT]
ALCK2: .REALT R,
JRST ALCK4
M30.: IMULI TT,30. ;NOTE: DOUBLE SKIP RETURN
JRST 2(T)
] ;END OF IFN ITS
IFE QIO,[
LISTEN: PUSH P,CFIX1
10% .LISTEN R,
IFN D10,[
SKIPE LINMODE
SKIPA TT,[SKPINL]
MOVSI TT,(SKPINC)
XCT TT
TDZA R,R
MOVEI R,1
] ;END OF IFN D10
SKIPE PBFTY
AOS R
HRRZ A,RDTYBF
JSP T,LNG1A
ADD TT,R
POPJ P,
] ;END OF IFE QIO
; ENDCODE [SLEEP/LISTEN/ALARM]
SUBTTL REMOB, ARG, SETARG, AND RECLAIM
REMOB: LOCKI ;SUBR 1 - REMOVE ATOMIC SYMBOL FROM OBARRAY
PUSHJ P,INTERN
JRST REMOB7
REMOB2: LOCKI
REMOB7: EXCH A,B ;OBTBL BUCKET # SHOULD BE IN TT
MOVE R,TT
HRRZ D,VOBARRAY
HRRI TT,@TTSAR(D)
PUSHJ P,ARYGT4
HLRZ T,(A)
CAIN T,(B)
JRST REMOB1
REMOB3: MOVE D,A
HRRZ A,(A)
HLRZ T,(A)
CAIE T,(B)
JRST REMOB3
HRRZ T,(A)
HRRM T,(D)
REMOB4: HLRZ TT,(B) ;LEAVE ATOM HEADER IN T
HRRZ TT,1(TT) ;LEAVE PNAME LINK IN TT
JSP T,GCP8L ;CHECK TO SEE THAT SCOS ARE REMOVED FROM SCO TABLE.
SETZB A,B
UNLKPOPJ
REMOB1: HRRZ A,(A)
JSP T,.STOR0
JRST REMOB4
ARG: JUMPE A,ARG3
ARGXX: JSP R,ARGCOM
HRRZ A,(D)
JRST PDLNKJ
ARG3: SKIPN ARGLOC
JRST ARGCM1
HRRZ A,ARGNUM
JRST PDLNKJ
SETARG: JSP R,ARGCOM
MOVE A,B
JSP T,PDLNMK
HRRM A,(D)
POPJ P,
ARGCOM: SKIPN D,ARGLOC
JRST ARGCM0
JSP T,FXNV1
JUMPLE TT,ARGCM8
CAMLE TT,@ARGNUM
JRST ARGCM8
ADD D,TT
JRST (R)
IFN BIGNUM+USELESS,[
RECLAIM: HRRZS A ;GC A PARTICULAR SEXP
JUMPE A,CPOPJ
LOCKI
PUSHJ P,RECL1
MOVEI A,NIL
UNLKPOPJ
] ;END OF IFN BIGNUM+USELESS
SUBTTL P.$X AND FRIENDS
10% DEPURE: JSR POFF ;DEPURIFY A PAGE
10% REPURE: JSR POFF ;REPURIFY A PAGE
SBSYM: JSR POFF ;FIND SUBR NAME (ADR IN RH OF .)
VCLSYM: JSR POFF ;FIND ATOM FOR VC (ADR IN LH OF .)
VCSYM: JSR POFF ;FIND ATOM FOR VALUE CELL
TLSYM: JSR POFF ;PRINT ST ENTRY OF LEFT HALF OF A CELL
TSYM: JSR POFF ;ST ENTRY OF RIGHT HALF
PLSYM: JSR POFF ;PRINT LEFT HALF OF A CELL
PSYM: JSR POFF ;PRINT RIGHT HALF OF A CELL
POF: JSR POFF ;PRINT ARG (POINTER AT LOC 40)
TOF: JSR POFF ;ST ENTRY OF ARG (POINTER IN 40)
10% P%OFF: JSR POFF ;FOR % TYPEOUT MODE IN DDT
10% PPTBL: JSR POFF ;PRINT OUT PURTBL
10% PPPAG: JSR POFF ;PRINT OUT ACTUAL PAGE STATUSES
;POFF: 0
PSYM1: SETOM PSYMF
MOVEM T,PSMTS ;P.$X, DONE IN DDT,
MOVEM R,PSMRS ; WILL PRINT CONTENTS
MOVEI T,LPSMTB ; OF CURRENT OPEN CELL
MOVE R,@PSMTB-1(T) ; IN LISP FORMAT.
MOVEM R,PSMS-1(T)
SOJN T,.-2
HRRZ T,POFF
10% CAIG T,REPURE+1
10% JRST PUFY
PUSH P,CPSYMX
JSP T,ERSTP
MOVEM P,ERRTN
MOVEI T,40
MOVEM T,PS.S
HRRZ R,POFF
IFN ITS,[
MOVEI T,THIRTY+7
CAIN R,P%OFF+1
MOVEM T,PS.S
CAIG R,POF
.BREAK 12,PSMST
] ;END OF IFN ITS
IFN D10,[
HRRZ T,.JBDDT"
HRRZ T,@6(T) ;WHAT A KLUDGE! 6?!!
CAIG R,POF
MOVEM T,PS.S
] ;END OF IFN D10
JSP T,SPECBIND
TTYOFF
TAPWRT
Q% LPTON
IFN MOBIOF, DISPON
V.RSET
10% V.NOPOINT ;FOR PPTBL
IFN USELESS, SETZM TYOSW
Q% MOVE T,VLINEL
Q% MOVEM T,VCHRCT
IFN QIO,[
HRRZ AR1,V%TYO ;UPDATE OUR NOTION OF THE
PUSHJ P,TTYBR1 ; LINENUM AND CHARPOS OF THE TTY,
MOVEI TT,AT.LNN ; SINCE DDT HAS SCREWED IT ALL UP.
HLRZM D,@TTSAR(AR1)
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(AR1)
] ;END OF IFN QIO
;;; FALLS THRU
;;; FALLS IN
HRRZ T,POFF
10% CAIL T,PPTBL+1
10% JRST PPTBL1
MOVE T,PSMTS ;AT THIS POINT ALL ACS WILL HAVE BEEN
MOVE R,PSMRS ; RESTORED SO THAT MOVE A,@ WILL WORK.
MOVE A,PSMS
Q$ MOVE AR1,PSMS+AR1-A
MOVE A,@PS.S ;THUS THIS STUFF WORKS IF . IS AN AC.
HRRZ T,POFF
10% CAIN T,P%OFF+1
10% JRST PSYMP1
CAIN T,POF+1
MOVEI T,PSYM+1
CAIN T,TOF+1
MOVEI T,TSYM+1
SUBI T,SBSYM
TRNE T,1
TLZA A,-1
HLRZS A
LSH T,-1
JRST .+1(T)
JRST PSYMSB ;SB.$X
JRST PSYMVC ;VC.$X AND VCL.$X
JRST PSYMT ;T.$X AND TL.$X AND TP FOO$X
PSYMP: PUSHJ P,PRIN1 ;P.$X AND PL.$X AND PP FOO$X
PSYMQ: MOVEI A,TRUTH ;RETURN POINT TO GET OUT OF PSYM1
JRST ERR2
PSYMX: MOVEI T,LPSMTB
MOVE R,PSMS-1(T)
MOVEM R,@PSMTB-1(T)
SOJN T,.-2
MOVE T,PSMTS
MOVE R,PSMRS
SETZM PSYMF
CPSYMX: POPJ P,PSYMX
IFN ITS,[
PSYMP1: TLNN A,-1 ;LISP MODE TYPEOUT - HACK TWO HALVES
JRST PSYMP
PUSH P,A
HLRZ A,A
PUSHJ P,PRIN1
MOVEI A,", ;SEPARATE HALVES WITH ",,"
REPEAT 2, PUSHJ P,TYO
POP P,A
TLZ A,-1
JRST PSYMP
] ;END OF IFN ITS
PSYMSB: MOVEI B,(A)
PUSHJ P,ERRADR ;ERRADR DOES ALL THE DIRTY WORK!
JRST PSYMQ
Q% FCN.H: ;FAKE CONTROL-H INTERRUPT FROM DDT
Q$ FCN.B: ;FAKE CONTROL-B INTERRUPT FROM DDT
Q% SKIPN INHIBIT
SKIPE NOQUIT
POPJ P,
SKIPGE INTFLG
POPJ P,
IFE QIO,[
PUSH P,A
MOVEI A,1
PUSHJ P,UINT
JRST POPAJ
] ;END OF IFE QIO
;;; FALLS THRU
;;; FALLS IN
IFN QIO,[
PUSH FXP,D
MOVE D,INHIBIT ;CROCK SO THAT A .5LOCKI
AOJE D,POPXDJ ; WON'T STOP US
PUSH FXP,INHIBIT
SETZM INHIBIT
MOVE D,[TTYIFA,,400000+↑B]
PUSHJ P,UINT
POP FXP,INHIBIT
POP FXP,D
POPJ P,
] ;END OF IFN QIO
TOF1: SKIPA T,[TOF]
POF1: MOVEI T,POF
PUSH P,UUOH
EXCH T,UUTSV
JRST @UUTSV
PSYMVC: MOVEI T,(A)
MOVEI A,QUNBOUND
CAIN T,SUNBOUND
JRST PSYMP
SKOTT T,LS
JRST PSVC1
JSP R,GCGEN
PSVC2
PSVC1: MOVEI A,QM
JRST PSYMP
PSVC2: HLRZ A,(D)
HLRZ B,(A)
HRRZ A,(B)
CAIN A,(T)
JRST PSVC3
HRRZ D,(D)
JUMPN D,PSVC2
JRST GCP8A
PSVC3: HLRZ A,(D)
JRST PSYMP
IFN ITS,[
PUFY: .BREAK 12,PSMST
MOVEI TT,@PS.S ;PURIFY THE PAGE THAT . IS ON
MOVE TT+1,TT ;USED BY DP≠X AND RP≠X
MOVEI C,-REPURE(T)
JSP R,IP0
JRST PSYMX
] ;END IFN ITS
;;; TABLE OF CELLS TO SAVE OVER THE PSYM FUNCTIONS
ZZ==. ;BE SURE TO SEE PSMS IF YOU CHANGE THIS TABLE
PSMTB: ;ACCUMULATOR A MUST BE THE FIRST ITEM, AND AR1 THE FOURTH
IRP FOO,,[A,B,C,AR1,AR2A,TT,D,F,40,UUOH,UUTSV,UUTTSV,UURSV,ERBDF,FPTEM]
FOO
TERMIN
IFN USELESS,[
PRINLV
TYOSW
ABBRSW
] ;END OF IFN USELESS
LPSMTB==.-ZZ ;FPTEM AND PCNT ARE SAME LOCATION
10% PSMST: 4,,PS.S-1 ;READ VALUE OF . FROM DDT WITH .BREAK 12,
; PP - A UUO ;PP IS FOR PRINTING OUT AN ADDRESS AS AN S-EXPRESSION:
;PP 34722$X IN DDT WILL PRINT OUT 34722 AS A
; POINTER IN LIST FORMAT.
; TP - A UUO ;TP IS LIKE PP BUT NICELY PRINTS ST ENTRY FOR
; THAT CELL
P.=PUSHJ P,PSYM ;P.$X IS LIKE PP FOO$X WHERE FOO IS RH OF.
PL.=PUSHJ P,PLSYM ;LIKE P., BUT FOR LH OF CURRENT CELL
10% P%=PUSHJ P,P%OFF ;LIKE P., BUT AS A DDT TYPEOUT MODE
VC.=PUSHJ P,VCSYM ;FIND NAME OF VALUE CELL RH OF . ADDRESSES
VCL.=PUSHJ P,VCLSYM ;A CROSS BETWEEN VC. AND PL.
T.=PUSHJ P,TSYM ;A CROSS BETWEEN P. AND TP
TL.=PUSHJ P,TLSYM ;A CROSS BETWEEN PL. AND TP
SB.=PUSHJ P,SBSYM ;FIND NAME OF SUBR ADDRESSED BY RH OF .
10% TBLPUR=PUSHJ P,PPTBL ;PRINT OUT PURTBL IN NICE FORM
10% PAGPUR=PUSHJ P,PPPAG ;PRINT OUT ACTUAL STATUS OF PAGES
Q% HH=PUSHJ P,FCN.H ;FAKE CONTROL-H INTERRUPT FROM DDT
Q$ BB=PUSHJ P,FCN.B ;FAKE CONTROL-B INTERRUPT FROM DDT
10% DP=PUSHJ P,DEPURE ;DEPURIFY PAGE . IS ON
10% RP=PUSHJ P,REPURE ;REPURIFY PAGE . IS ON
; ENDCODE [P.$X]
SUBTTL T.$X AND TBLPUR$X STUFF
PSYMT: PUSHJ P,ITERPRI ;T.$X TYPEOUT, ETC.
MOVEI TT,(A)
ROT TT,-SEGLOG
MOVE TT,ST(TT)
SETZB T,C
MOVNI R,22
PSYMT1: LSHC T,1
TRZN T,1
JRST PSYMT3
MOVEI A,"+
TROE C,1
PUSHJ P,TYO
MOVEI B,PSYMTT+22(R)
CAIL B,PSYMTT+PSYMTL
MOVEI B,[ASCII \??\]
HRLI B,440700
PSYMT2: ILDB A,B
JUMPE A,PSYMT3
PUSHJ P,TYO
JRST PSYMT2
PSYMT3: AOJL R,PSYMT1
MOVEI A,",
REPEAT 2, PUSHJ P,TYO
HLRZ A,TT
PUSHJ P,PRINC
JRST PSYMQ
;;; MUST MATCH THE IRP WHICH DEFINES THESE AS SYMBOLS!
PSYMTT:
IRP TP,,[LS,$FS,$FX,$FL,BN,SY,SA,VC,$FXP,$FLP,$XM,$NXM,PUR,HNK]
ASCII \TP\
TERMIN
PSYMTL==.-PSYMTT
IFN ITS,[
PPTBL1: MOVEI F,-PPTBL-1(T) ;0 => TBLPUR$X, 1 => PAGPUR$X
JSP T,0PUSH-4
MOVE R,[440200,,PURTBL]
MOVEI T,1
PPTBL2: ILDB TT,R
JUMPE F,PPTBL6
.CALL PPTBL8
.VALUE
ASH TT,-41
TRZ TT,1
SKIPGE TT
MOVEI TT,1 ;0=NONX, 1=IMPURE, 2=PURE
PPTBL6: MOVEI A,(FXP)
SUBI A,(TT)
AOS (A)
MOVEI A,"0(TT)
PUSHJ P,TYO
TRNE T,7
AOJA T,PPTBL2
TRNN T,30
JRST PPTBL3
MOVEI A,40
PUSHJ P,TYO
TRNE T,10
AOJA T,PPTBL2
PUSHJ P,TYO
PUSHJ P,TYO
JRST PPTBL4
PPTBL3:
Q$ PUSH FXP,T
PUSHJ P,ITERPRI
Q$ POP FXP,T
CAIN T,NPAGS
JRST PPTBL5
PPTBL4: TLZ R,770000
AOJA T,PPTBL2
PPTBL5: MOVEI R,TYO
MOVNI TT,4
PPTBL7: EXCH TT,(FXP)
JUMPE TT,PPTBL9
MOVEI A,↑I
PUSHJ P,TYO
MOVE A,(FXP)
ADDI A,"4
PUSHJ P,TYO
XCT "-,CTY
MOVEI C,10.
PUSHJ P,PRINI2
POP FXP,TT
PPTBL9: AOJL TT,PPTBL7
JRST PSYMQ
PPTBL8: SETZ
SIXBIT \CORTYP\
1000,,-1(T)
402000,,TT
] ;END OF IFN ITS
SUBTTL PURIFY≠G ROUTINE
IFN ITS,[ ;DOESN'T REALLY WORK FOR D10 YET
PURIFY: JRST NOTINIT ;CLOBBERED BY INIT TO "SETO AR1,"
; SETO AR1, ;FOR PURIFY$G FROM DDT
MOVE P,[-LFAKP-1,,FAKP-1]
MOVE FXP,[-LFAKFXP-1,,FAKFXP-1]
JRST FPURF7
FPURF2: SETZB TT,PSGAOB ;ZERO PURE SEGMENT AOBJN PTR
SETZM NPFFS ;ZERO PURE FREE STORAGE COUNTERS
SETZM NPFFX
SETZM NPFFL
BG$ SETZM NPFFB
SETZM NPFFY2
MOVSI R,400000
SKIPE LDXBLT ;IF ANY XCT CALL AREA, WILL
IORM R,LDXSIZ ; PURIFY, HENCE CAN ADD NO CALLS
IFN D10,[
OUTSTR [ASCIZ \:$PURIFIED$
\]
EXIT 1,
] ;END OF IFN D10
IFN ITS,[
MOVNI R,NPAGS ;SO STEP THROUGH LOSING PURTBL
MOVE D,[440200,,PURTBL] ; TO DECIDE HOW TO MUNG PAGES
IPUR1: ILDB T,D ;GET BYTE FOR NEXT PAGE
JRST .+1(T)
JRST IPUR3 ;0 - DELETE
JRST IPUR4 ;1 - IMPURIFY
JRST IPUR6 ;2 - PURIFY
MOVEI T,400(R) ;3 - HAIRY STUFF - DECODE FURTHER
LSH T,PAGLOG
CAMGE T,BPSL ;CODE 3 SHOULD NEVER APPEAR
.VALUE ; BELOW BINARY PROGRAM SPACE
MOVE F,@VBPORG ;PAGIFY CURRENT VALUE OF
ANDI F,PAGMSK ; BPORG DOWNWARD
CAIGE T,(F) ;ANY CODE 3 PAGE BELOW THAT CAN
JRST IPUR6A ; BE PURIFIED
CAMG T,BPSH ;ANY CODE 3 PAGE BETWEEN BPORG
JRST IPUR2 ; AND BPSH IS LEFT AS IS
CAMG T,HINXM ;ANY PAGE BETWEEN BPSH AND HINXM
.VALUE ; DAMN WELL BETTER BE 0!!!
HRRZ F,PDLFL1 ;ANYTHING BETWEEN HINXM AND
LSH F,PAGLOG ; PDLS MUST BE PURE FREE STORAGE
CAIGE T,(F)
JRST IPUR6A
CAIGE T,BSCRSG ;SCRATCH PAGES ARE IGNORED
JUMPL AR1,IPUR3A ;PDL PAGES MAY OR MAY NOT BE
IPUR2: ADDI TT,1001 ; FLUSHED, DEPENDING ON AR1
TLNN D,730000 ;ONLY 20 2-BIT BYTES PER WORD, NOT 22
TLZ D,770000
AOJL R,IPUR1
JUMPGE AR1,POP1J
MOVE T,[ITSMSK]
MOVEM T,INTMSK
Q$ MOVE T,[ITSMS2]
Q$ MOVEM T,INTMS2
.VALUE [ASCIZ \:≠PURIFIED≠
\]
] ;END OF IFN ITS
] ;END OF IFN ITS (THE BIG ONE)
IFN ITS,[
IPUR3A: SKIPE NOPFLS
JRST IPUR2
SETZ T,
DPB T,D
IPUR3: TRZ TT,400000 ;DELETE A PAGE
.CBLK TT,
.VALUE
JRST IPUR2
IPUR4: .CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPL T,IPUR2 ;ALREADY IMPURE
IOR TT,[4400,,400000]
JUMPG T,IPUR5
.CBLK TT, ;NON-EXISTENT - GET A PAGE
.VALUE
JRST IPUR2
IPUR5: TLZ TT,4000 ;PURE - TRY TO DEPURIFY
.CBLK TT,
JSP F,IP1 ;IF WE LOSE, TRY COPYING
JRST IPUR2
IPUR6A: MOVEI T,2
DPB T,D
IPUR6: .CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPG T,IPUR2 ;ALREADY PURE
JUMPE T,IPUR7 ;CAN'T PURIFY A NON-EXISTENT PAGE
TLZ TT,4400 ;PURIFY AN IMPURE PAGE
TRO TT,400000
.CBLK TT,
IPUR7: .VALUE
JRST IPUR2
] ;END OF IFN ITS
IFN EDFLAG,[
;;@ EDITOR 14 KLUDGY BINFORD EDITOR
SUBTTL KLUDGY BINFORD EDITOR
EDPRW==13 ;PRINT WIDTH,PRINT N ATOMS ON
;EITHER SIDE OF POINTER
R4==AR1
R5==AR2A
R6==T
EDIT: MOVE B,A
JSP T,RSXST
JSP D,BRGEN ;ERRSET LOOP
JUMPE B,EDTTY
HLRZ A,(B)
JSP T,SPATOM
JRST EDERRC
PUSH P,CEDTTY
JRST EDY0
EDTTY: SKIPE EDPRFL
PUSHJ P,EDPRINT
EDTTY4: MOVEI C,0 ;INIT NUMBER
MOVEI B,0 ;INIT SYMBOL,NUMBERS COME HERE
MOVE R4,[220600,,B] ;SETUP BYTEP
EDTYIN:
Q% PUSHJ P,TYIN ;READ ASCII VALUE OF CHAR
Q$ SETZM BFPRDP
Q$ PUSH P,R4 ;ALIAS AR1, WHICH TYI CLOBBERS
Q$ PUSHJ P,TYI
Q$ POP P,R4
MOVE R5,@RSXTB
NW% TLNN R5,4
NW$ TRNN R5,RS.DIG
JRST EDTTY1 ;NOT NUMBER
EDNUM: IMULI C,10. ;ACCUMULATE DECIMAL NUMBER
NW% ADDI C,-"0(R5)
NW$ ANDI R5,777
NW$ ADDI C,-"0(R5)
JRST EDTYIN
EDTTY1: CAIE A,15
CAIN A,12
JRST EDTYIN
CAIE A,33
CAIN A,177
JRST EDTTY3
CAIN A,40
JRST EDTTY2
NW% TLNN R5,377777
NW$ TDNN R5,[001377777000] ;??
JRST EDTYIN
NW% TLNN R5,70053 ;LEGIT CHARS ARE <ALPHA> ( ) - , .
NW$ TDNN R5,[RS.LTR+RS.XLT+RS.LP+RS.RP+RS.DOT+RS.SGN+RS.ALT] ;RS.ALT??
JRST EDERRC
ADDI R5,40
TLNE R4,770000 ;SIXBIT THREE CHARS
IDPB R5,R4
JRST EDTYIN ;READ NEXT CHAR
EDTTY2: JUMPE B,EDTYIN ;IGNORE LEADING SPACES
PUSHJ P,EDSYM
JRST EDTTY
EDTTY3: SKIPE EDPRFL
STRT [SIXBIT \↑M $$ ↑M!\]
JRST EDTTY4
;SEARCH SYMBOL TABLE
EDSYM: MOVEI R5,EDSYML-1
EDSYM1: MOVS R6,EDSYMT(R5)
CAIE B,(R6)
SOJGE R5,EDSYM1
JUMPL R5,EDSYM3
EDEXEC: HLRZM R6,EDEX2 ;GET COMMAND ADDRESS
CAIL R5,EDRPT
JRST @EDEX2 ;NO REPEAT ON THESE COMMANDS
EDEX1: PUSH P,C
PUSHJ P,@EDEX2 ;EXECUTE COMMAND
SOSLE C, (P)
JUMPN A,.-2
EDEX3: JRST POPBJ
EDSYM3: PUSH FXP,C
MOVE C,[440700,,PNBUF]
MOVE R4,[440600,,B]
MOVSI B,(B)
SETOM LPNF
SETZM PNBUF
JRST EDSYM5
EDSYM4: ADDI A,40
IDPB A,C
EDSYM5: ILDB A,R4
JUMPN A,EDSYM4
PUSHJ P,RINTERN
MOVEI B,QEDIT
PUSHJ P,GET
POP FXP,TT
JUMPE A,EDERRC
MOVEI AR1,(A)
JSP T,FIX1A
HRRZ B,VDLDLDL
HRRZ C,EDUPLST
JCALLF 3,(AR1)
EDERRC: STRT [SIXBIT \?? !\]
CEDTTY: JRST EDTTY
EDSYMT: ;COMMAND TABLE
EDSYMB: +(SIXBIT \B\),,EDB ;BACK,LEFT PAST ATOM
+(SIXBIT \D\),,EDDOWN ;DOWN
EDSYMF: +(SIXBIT \F\),,EDF ;FORWARD,RIGHT ATOM
+(SIXBIT \U\),,EDUP ;UP
+(SIXBIT \L\),,EDLL ;LEFT PAST S-EXPR
+(SIXBIT \R\),,EDRR ;RIGHT PAST S-EXPR
+(SIXBIT \K\),,EDKILL ;KILL
+(SIXBIT \-K\),,EDLKILL ;LEFT, THEN KILL
+(SIXBIT \-L\),,EDRR
+(SIXBIT \-R\),,EDLL
+(SIXBIT \PW\),,EDPW ;SET PRINT WIDTH
EDSYMP: +(SIXBIT \PQ\),,EDPRA ;INTERNAL PRINT
+(SIXBIT \EV\),,REP ;EVAL
+(SIXBIT \I\),,EDI ;INSERT
+(SIXBIT \KI\),,EDKI ;REPLACE,I E KILL INSERT
+(SIXBIT \-KI\),,EDMKI ;REPLACE TO LEFT
+(SIXBIT \IV\),,EDIV ;INSERT VALUE OF ARG
+(SIXBIT \P\),,EDPR0 ;PRINT
+(SIXBIT \Q\),,EDQ ;QUIT,EXIT FROM EDIT
+(SIXBIT \S\),,EDS ;SEARCH
+(SIXBIT \SS\),,EDSAVE ;SAVE SPOT
+(SIXBIT \RS\),,EDRSTR ;RESTORE SPOT
+(SIXBIT \SP\),,EDCHPR ;START-PRINTING (OR STOP-PRINTING)
+(SIXBIT \J\),,EDTOP ;TOP
+(SIXBIT \Y\),,EDY ;YANK
+(SIXBIT \YP\),,EDYP ;YANK PROP LIST, OR SPECIFIC PROPERTY
+(SIXBIT \(\),,EDLP. ;INSERT VIRTUAL LEFT PAREN
+(SIXBIT \)\),,EDRP. ;INSERT VIRTUAL RIGHT PAREN
+(SIXBIT \D(\),,EDXLP ;VIRTUAL DELETION OF PAREN
+(SIXBIT \D)\),,EDXLP ;VIRTUAL DELETION OF PAREN
+(SIXBIT \()\),,EDZZ ;RESTRUCTURE ACCORDING TO VIRTUAL PARENS
EDSYML==.-EDSYMT
EDRPT==EDSYMP+1-EDSYMT ;NO REPEAT FOR COMMANDS ABOVE EDSYMP
;EDIT MANIPULATES TWO LISTS FOR BACKING UP
;THE LEFT LIST CALLED L (VALUE OF $$$ (3 ALTMODES))
;RIGHT: (COND ((PTR (CAR L)) (SETQ L (CONS (CDAR L) L))))
;LEFT: (COND ((PTR L) (SETQ L (CDR L))))
;THE UP LIST U (KEPT AT EDUPLST)
;DOWN: (COND ((AND (PTR (CAR L)) (PTR (CAAR L)))
; (SETQ U (CONS L U))
; (SETQ L (LIST L))))
;UP: (COND ((PTR U) (SETQ L (CAR U))
; (SETQ U (CDR U))))
EDQ: MOVEI A,Q.
MOVEI B,QBREAK
JRST THROW1 ;THROW OUT OF BREAK ERRSET LOOP
;RIGHT PAST S-EXPR
;USES ONLY A,B ;NIL IF FAILS
EDR: PUSHJ P,EDCAR
JRST FALSE ;NOT A PTR
HRRZ A,(A) ;TAKE CDAR L
HRRZ B,VDLDLDL
PUSHJ P,CONS ;CONS ONTO L
EDR1: HRRZM A,VDLDLDL ;STORE IN L
POPJ P, ;NON-ZERO,VALUE EDIT
EDLEFT: SKIPE A,VDLDLDL ;TAKE CDR IF NON-NIL
HRRZ A,(A)
JUMPE A,FALSE
JRST EDR1
;DOWN ONE LEVEL
;USES ONLY A,B
;NIL IN A IF FAILS
EDDOWN: PUSHJ P,EDCAAR ;IS (CAAR L) A PTR
JRST FALSE ;NOT PTR
PUSHJ P,NCONS
EXCH A,VDLDLDL ;STORE IN L
HRRZ B,EDUPLST
PUSHJ P,CONS ;CONS L U
EDD1: HRRZM A,EDUPLST ;STORE IN U
POPJ P, ;NON-ZERO
;BACK
EDB: PUSHJ P,EDLEFT ;LEFT?
JUMPE A,EDUP
PUSHJ P,EDCAAR ;NEXT IS ATOM?
JRST TRUE
EDB1: PUSHJ P,EDDOWN ;DOWN
JUMPE A,EDUP
EDXR: PUSHJ P,EDR ;EXTREME RIGHT
JUMPN A,.-1
JRST TRUE
;FORWARD
;RIGHT ATOM
EDF: PUSHJ P,EDCAR ;CAR L PTR?
JRST EDF2 ;NOT PTR
PUSHJ P,EDCAR1 ;(CAAR L) ATOM
JRST EDR ;ATOM,GO RIGHT
EDF1: PUSHJ P,EDDOWN ;DOWN?
JUMPN A,CPOPJ
EDF2: PUSHJ P,EDUP ;UP?
JUMPN A,EDR ;AND RIGHT?OTHERWISE FALLS THROUGH TO EDUP
EDUP: SKIPN A,EDUPLST ;UP ONE LEVEL
JRST FALSE
MOVE A,(A)
JUMPE A,FALSE
HLRZM A,VDLDLDL ;L=(CAR U)
JRST EDD1
EDRR: PUSHJ P,EDR
JUMPN A,CPOPJ
JRST EDF
EDLL: PUSHJ P,EDLEFT
JUMPN A,CPOPJ
JRST EDUP
REP: PUSHJ P,IREAD
PUSHJ P,EVAL
JRST TLPRINT
EDPR0: SKIPE EDPRFL
POPJ P,
EDPRINT: PUSH P,VDLDLDL
PUSH P,EDUPLST ;SAVE CURRENT LOCATION
PUSHJ P,TERPRI
MOVN C,EDPRN ;ATOM COUNT
PUSHJ P,EDB ;MOVE BACK N TOKENS
JUMPE A,.+2
AOJL C,.-2
ADD C,EDPRN ;PRINT FORWARD 2N ATOMS
ADD C,EDPRN
MOVEI T,EDPRA
MOVEM T,EDEX2
SKIPE EDPRN
PUSHJ P,EDEX1
PUSHJ P,TERPRI
EDPRX: POP P,EDUPLST ;RESTORE CURRENT LOCATION
POP P,VDLDLDL
POPJ P,
EDPRA: MOVSI T,400000
CAME C,EDPRN ;CURRENT LOCATION?
JRST .+3
STRT [SIXBIT \ $$ !\] ;PRINT ** CURSOR
ANDCAM T,EDEX2
SKIPN A,VDLDLDL
JRST EDF ;EXIT IF NOTHING MORE
PUSH P,.-1 ;PRINT ONE TOKEN AND MOVE FORWARD
PUSHJ P,EDCAR1 ;(CAR L) A PTR
JRST EDPRG
SKIPGE EDEX2 ;OUTPUT A SPACE IF PREVIOUS EDPRA
STRT [SIXBIT \ !\] ; CALL REQUESTED IT
IORM T,EDEX2 ;ASSUMING NEXT IS ATOM, ASK FOR SPACE
PUSHJ P,EDCAR1
JRST IPRIN1 ;(CAAR L) IS ATOM, SO PRIN1 IT
ANDCAM T,EDEX2 ;IF NOT, REVOKE REQUEST FOR NEXT SPACE
MOVEI A,"( ;AND BEGIN PRINTING A LIST
JRST TYO
EDPRG: IORM T,EDEX2 ;SINCE THIS SECTIONS ENDS BY PRINTING
JUMPE A,EDPRG1 ;A ")", THEN REQUEST SPACE ON NEXT
STRT [SIXBIT \ . !\]
PUSHJ P,IPRIN1
EDPRG1: MOVEI A,")
JRST TYO
EDSAVE: PUSHJ P,READ ;SAVE CURRENT EDITING SPOT AS THE VALUE OF SOME ATOM
SKIPN AR1,A
JRST EDERRC
PUSHJ P,TYPEP
CAIE A,QSYMBOL
JRST EDERRC
MOVE A,VDLDLDL
MOVE B,EDUPLST
PUSHJ P,CONS
JSP T,.SET
POPJ P,
EDRSTR: PUSHJ P,READ ;SET CURRENT EDITINT SPOT TO THAT SAVED UP IN SOME ATOM
PUSHJ P,EVAL
HLRZ B,(A)
MOVEM B,VDLDLDL
HRRZ A,(A)
MOVEM A,EDUPLST
POPJ P,
EDCHPR: SETCMM EDPRFL
POPJ P,
EDPW: MOVEM C,EDPRN ;SET PRINT WIDTH
MOVEI A,NIL
JRST POPJ1
EDCAAR: PUSHJ P,EDCAR
EDCAR: SKIPE A,VDLDLDL
EDCAR1: HLRZ A,(A) ;MUST PRESERVE T FOR EDPRA
SKIPN TT,A
POPJ P,
LSH TT,-SEGLOG
SKIPGE ST(TT)
AOS (P)
POPJ P,
;INSERT:(SETQ L2(CAR L))
; (COND((LEFT)(RPLACD(CAR L)(CONS I L2))
; (RIGHT)(RIGHT))
; ((UP)(RPLACA(CAR L)(CONS I L2))
; (DOWN)(RIGHT)))
;KILL:(SETQ L2(CAR L))
; (COND((LEFT)(RPLACD(CAR L)(CDR L))
; (RIGHT))
; ((UP)(RPLACA(CAR L)(CDR L2))
; (DOWN)))
;INSERT ONE S-EXPR
;USES A,B AND WHATEVER READ SMASHES
EDI: PUSHJ P,EDREAD ;GET S-EXPR
EDIB: MOVEI D,EDIA
JRST EDMAP
EDIV: PUSHJ P,READ
PUSHJ P,EVAL
MOVE B,A
EDIA: SKIPE A,VDLDLDL
HLRZ A,(A)
EDIC: PUSHJ P,XCONS
MOVE B,A
EDID: PUSHJ P,EDK1
JRST EDR
EDLKILL: PUSHJ P,EDLEFT
JUMPE A,CPOPJ
EDKILL:
EDKA: PUSHJ P,EDCAR ;KILL ONE S-EXP
SKIPA B,A ;USES A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZM A,VDOLLAR
EDK1: PUSHJ P,EDLEFT ;LEFT?
JUMPE A,EDI2
PUSHJ P,EDCAR
JRST EDI2
HRRM B,(A) ;(RPLACD (CAR L) Q)
EDK2: JRST EDR
;RETURNS NIL IF FAILS
EDI2: PUSHJ P,EDUP ;UP?
JUMPE A,FALSE
PUSHJ P,EDCAR ;IS (CAR L) POINTER
JRST FALSE
HRLM B,(A) ;(RPLACA (CAR L) Q)
EDI3: JRST EDDOWN
EDRDATOM: PUSHJ P,READ
MOVE B,A
PUSHJ P,ATOM
JUMPN A,SPROG2
JRST EDERRC
EDY: PUSHJ P,EDRDATOM
EDY0: MOVE B,VEDIT
PUSHJ P,GETLA
JUMPE A,EDERRC
EDYX: PUSHJ P,NCONS
EDYX1: SETZM EDUPLST
JRST EDR1
EDYP: PUSHJ P,EDREAD
HRRZ B,(A)
JUMPE B,EDY1
HLRZ A,(A)
EDY2: HLRZ B,(B)
MOVEI C,(B)
PUSHJ P,GET
CAIE C,QVALUE
JRST EDYX
HRRZ A,(A)
CAIN A,QUNBOUND
JRST EDERRC
JRST EDYX
EDY1: HLRZ A,(A) ;GET ATOM READ
HRRZ A,(A) ;GET ITS PLIST
JRST EDYX
;READS A STRING OF S-EXPRS TERM BY ≠≠
;FORMS A LIST IN PROPER DIRECTION
EDREAD: PUSHJ P,IREAD ;GET S-EXPR
CAIN A,DOLLAR ;$$ TERMINATES
JRST FALSE
PUSH P,A
PUSHJ P,EDREAD ;FORM LIST BY RECURSION
JRST SUBS3
;SEARCH
;PERMITS SEARCH FOR FRAGMENTS OF AN
;S-EXPR. FORMATS 3S A B C ≠≠
;3S A B C /) $$ OR S /( X Y Z ≠≠
EDS: PUSH P,VDLDLDL
PUSH P,EDUPLST ;SAVE ORIGINAL LOCATION
PUSH P,C ;SAVE COUNT
PUSHJ P,EDREAD ;READ STRING OF S-EXPRS
JUMPN A,.+2
SKIPA A,EDSRCH
MOVEM A,EDSRCH
PUSH P,A ;SAVE READ LIST
EDS1: PUSH P,VDLDLDL
PUSH P,EDUPLST
EDS11: MOVE A,-2(P) ;ARG IN B
MOVEI D,EDS3
PUSHJ P,EDMAP ;DOES CURRENT LOC MATCH?
JUMPN A,EDSN ;WE HAVE A MATCH
EDS1A: POP P,EDUPLST
POP P,VDLDLDL
PUSHJ P,EDF ;NO MATCH,GO RIGHT ATOM
JUMPN A,EDS1 ;FINISHED,SEARCH FAILS
EDSF: SUB P,R70+2
JRST EDPRX ;EXIT RESTORE ORIG LOC
EDSN: SOSLE -3(P) ;DECREMENT COUNT
JRST EDS11 ;NOT FININSHED,MATCH AGAIN
SUB P,R70+6 ;RESTORE PDL
JRST FALSE ;TO AVOID REPEATS BY EDEV
;TEST CURRENT LOCATION
;A IS QUANTITY TO TEST
;(CAR L) IS THE CURRENT LIST
;(COND
; ((NULL(PTR(CAR L)))
; (COND((EQ A(QUOTE /) ))(RIGHTA))))
; ((NULL(PTR(CAAR L)))
; (COND((EQ A(CAAR L))(RIGHTA))))
; ((EQUAL A(CAAR L))(RIGHT))
; ((EQ A(QUOTE /())(RIGHTA)))
;TEST CURRENT LOCATION
;ARG A IS IN B
EDS3: PUSHJ P,EDCAR ;IS(CAR L)POINTER
JRST FALSE
HLRZ A,(A)
PUSHJ P,EQUAL ;(EQUAL A(CAAR L))
JUMPE A,FALSE
JRST EDR
;MAP DOWN LIST
EDMAP: MOVE R,A
EDMAP2: JUMPE R,TRUE
HLRZ B,(R) ;TAKE CAR
PUSHJ P,(D) ;FUNARG
JUMPE A,CPOPJ ;MATCH FAILS
HRRZ R,(R)
JRST EDMAP2
EDTOP: MOVEI C,100000
HLRZ B,EDSYMB
JRST EDSYM
EDMKI: PUSHJ P,EDLEFT
JUMPE A,CPOPJ
EDKI: PUSHJ P,READ
EDKI1: MOVE B,A
PUSHJ P,EDCAR ;IF PTR IS ATOM RPLACD
JRST EDID
HRLM B,(A) ;RPLACA
JRST EDR
; ;(CAAR L) ATOM MATCH ONLY (EQ A(CAAR L))
;EDS3B: CAME A,B
; JRST FALSE
; JRST EDR
; ;CURRENT LIST FINISHED,CAN ONLY MATCH /)
;EDS3A: JUMPN A,EDS3B
; CAIN B,RPAREN
; JRST EDF
; JRST FALSE
;EDIP: PUSHJ P,EDCAR ;INSERT PARENS
; JUMPN A,FALSE ;AROUND NEXT ELEMENT
; HLRZ A,(A)
; PUSHJ P,NCONS
; JRST EDKI1
;
;EDDP: PUSHJ P,EDCAAR ;DELETE PARENS
; JRST FALSE
; PUSHJ P,EDIB
; JRST EDKA
EDRP.: SKIPA B,CEDRP
EDLP.: MOVEI B,EDLP ;INSERT VIRTUAL LEFT PAREN
JRST EDIA
EDXLP: MOVEI B,EDSTAR ;INSERT CHAR TO DELETE NEXT PAREN
JRST EDIA
EDZZ: PUSHJ P,EDTOP ;RESTRUCTURE W/ VIRTUAL PARENS
PUSHJ P,EDF
PUSHJ P,EDXA
PUSH P,A
PUSHJ P,EDTOP
PUSHJ P,EDF
POP P,A
JRST EDKI1
EDXE: SKIPE A,EDUPLST
PUSHJ P,EDF
EDXZ: SKIPE A,EDUPLST
EDXA: PUSHJ P,EDF ;FORWARD
EDXX: SKIPE A,EDUPLST
PUSHJ P,EDCAR ;(PTR(CAR L))
POPJ P, ;ATOM(CAR L)
HLRZ B,(A) ;(CAAR L)
CEDRP: CAIN B,EDRP ;IS IS /)?
JRST FALSE ;SKIP AND RETURN FALSE
CAIN B,EDSTAR
JRST EDXE
; CAIN B,EDDOT ;IS IT /.?
; JRST EDXD ;SKIP AND (EDXX(CAR A))
PUSH P,A
PUSHJ P,EDCAAR
PUSHJ P,EDXY
EDXG: PUSHJ P,EDXZ ;CONS(EDXX(CAR A))(EDXX(CDR A)))
EDXGA: PUSH P,A
PUSHJ P,EDXZ
POP P,C
POP P,B
HRLM C,(B) ;RPLACA A (EDXX(CAR A))
HRRM A,(B)
EXPOP: EXCH A,B
POPJ P,
EDXY: CAIE A,EDLP
JRST POPJ1
POPJ P,
;;@ END OF EDITOR 14
]
SUBTTL PURE COPY OF THE READ SYNTAX TABLE
-1,,0 ;FOR NEWRD WILL POINT TO MACRO CHAR LIST
RSXTB2: PUSH P,CFIX1
JSP TT,1DIMF
NIL ;SHOULD NEVER ACTUALLY CALL
0
RCT0:
IFE NEWRD,[ ;OLD VERSION OF PURE READTABLE
IFN SAIL,[
REPEAT 11, 2,,.RPCNT ;SAIL CHARS
500500,,↑I ;TAB
500500,,↑J
400500,,↑K
400500,,↑L
400500,,↑M ;CR
REPEAT 22, 2,,↑N+.RPCNT ;SAIL CHARS
] ;END IFN SAIL
.ELSE,[
REPEAT 10, 400500,,.RPCNT ;↑@ ↑A ↑B ↑C ↑D ↑E ;↑F ↑G
Q% 400500,,↑H ;↑H
Q$ 2,,↑H ;↑H
500500,,↑I ;TAB
REPEAT 7, 400500,,↑J+.RPCNT ;↑J ↑K ↑L ↑M ↑N ↑O ↑P
Q% 400500,,↑Q ;↑Q
Q$ 405540,,QCTRLQ ;↑Q
400500,,↑R ;↑R
Q% 400500,,↑S ;↑S
Q$ 405540,,QCTRLS ;↑S
REPEAT 7, 400500,,↑T+.RPCNT ;WORTHLESS
2,,33 ;ALT MODE
REPEAT 4, 400500,,↑\+.RPCNT ;WORTHLESS
] ;END IFE SAIL
500500,,40 ;SPACE
REPEAT 6, 2,,"!+.RPCNT ;! " # $ % &
404500,,QRDQTE ;'
440500,,"( ;(
410500,,") ;)
2,,"* ;*
10,,"+ ;+
500500,,", ;,
50,,"- ;-
420700,,". ;.
402500,,"/ ;/
REPEAT 10., 4,,"0+.RPCNT ;DECIMAL DIGITS
2,,": ;:
404540,,QRDSEMI ;;
REPEAT 5, 2,,"<+.RPCNT ;< = > ? @
REPEAT 26., 1,,"A+.RPCNT ;ALPHABETIC
REPEAT 3, 2,,133+.RPCNT ;[ \ ]
22,,"↑ ;↑
62,,"← ;←
2,,"` ;ACCENT GRAVE
REPEAT 26., 501,,"A+.RPCNT ;SMALL LETTERS
2,,173 ;LEFT BRACE
404500,,QRDVBAR ;VERTICAL BAR
REPEAT 2, 2,,175+.RPCNT ;RIGHT BRACE, TILDE
401500,,177 ;RUBOUT
IFN .-RCT0-200, WARN [READTABLE LOSSAGE]
402500,,57 ;PSEUDO SLASHIFIER CHARACTER
440500,,50 ;PSEUDO OPEN PARENS
410500,,51 ;PSEUDO CLOSE PARENS
500540,,40 ;PSEUDO SPACE
SA$ REPEAT 574, 400500,,204+.RPCNT ;SAIL CONTROL CHARS
] ;END OF IFE NEWRD
;;; MORE ON NEXT PAGE
IFN NEWRD,[ ;NEW VERSION OF PURE READTABLE
REPEAT 11, RS.BRK+RS.SL1+RS.SL9 + .RPCNT ;WORTHLESS CONTROL CHARS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 11 ;TAB
REPEAT 21, RS.BRK+RS.SL1+RS.SL9 + 12+.RPCNT ;WORTHLESS
RS.XLT + 33 ;ALTMODE
REPEAT 4, RS.BRK+RS.SL1+RS.SL9 + 34+.RPCNT ;WORTHLESS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;SPACE
REPEAT 6, RS.XLT + 41+.RPCNT ;! " # $ % &
RS.BRK+RS.SL1+RS.SL9+RS.MAC + 47 ;'
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;(
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;)
RS.XLT + 52 ;*
RS.SL1+RS.SGN + 53 ;+
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 54 ;,
RS.SL1+RS.SGN+RS.ALT + 55 ;-
RS.BRK+RS.SL1+RS.SL9+RS.DOT+RS.PNT + 56 ;.
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;/
REPEAT 10., RS.SL1+RS.DIG + 60+.RPCNT ;0 - 9
RS.XLT + 72 ;:
RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.ALT + 73 ;;
REPEAT 5, RS.XLT + 74+.RPCNT ;< = > ? @
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D
RS.LTR + RS.SQX + 105 ;E
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z
REPEAT 3, RS.XLT + 133+.RPCNT ;LBRACK BSLASH RBRACK
RS.ARR+RS.XLT + 136 ;↑
RS.ARR+RS.ALT+RS.XLT + 137 ;←
RS.XLT + 140 ;ACCENT GRAVE
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D L.C.
RS.LTR+RS.SQX + 105 ;E L.C.
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z L.C.
REPEAT 4, RS.XLT + 173+.RPCNT ;LBRACE VBAR RBRACE TILDE
RS.BRK+RS.SL1+RS.SL9+RS.RBO + 177 ;RUBOUT
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;PSEUDO SLASH
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;PSEUDO (
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;PSEUDO )
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;PSEUDO SPACE
] ;END OF IFN NEWRD
TLRCT==<.-RCT0>
ZZ==LRCT-TLRCT
IFE NEWRD,[
IFL ZZ-1-2, INFORM READER-TABLE-DEFICIENCY,\<3-ZZ>
.ELSE BLOCK ZZ-3
] ;END OF IFE NEWRD
,,TRUTH ;,,(STATUS *BAR)
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; *BAR=NIL => NO |'S, *BAR=*BAR => ALWAYS, *BAR=T => HEURISTIC
;;; TTYREAD=NIL => ONLY FORCE FEED CHARS LET READ SEE THE TTY BUFFER
;;; ABBREVIATE: 1.1 => ABBREV FILES, 1.2 => ABBREV FLATSIZE/EXPLODE
;;; TERPRI=T => DO NOT OUTPUT AUTOMATIC NEWLINES
;;; ←=T => ALLOW PRIN1/PRINC TO OUTPUT FIXNUMS IN FORM M←N
SUBTTL TOP PAGE PGTOP, AND SOME INSRTS
MOVEI 1,[.] ;THIS WASTEFUL HAC IS MERELY TO INSURE THAT THE LAST
MOVEI 2,[.] ;FEW CONSTANTS ON THIS PART ARE WORTHLESS
MOVEI 3,[.] ;IN CASE THERE ARE MORE ON PASS2 THAN PASS1
PGTOP TOP,[TOPLEVEL, COMMON, AND RANDOM STUFF]
;;; HERE IS A SUNDER HAC - IT MUST BE ABLE TO FIND
;;; <LF>$INSRT<SP>NAME<TABS-OR-SPACES>;COMMENTS ON FILE
IFN MOBIOF,[
;;@ MOBYIO 13 MOBY I/O PACKAGE
PGBOT MIO
SUBTTL VIDISECTOR ROUTINES
NVID: PUSHJ P,NVIDI ;BREAKS OUT WITH POPJ IF LOSES
TLNE TT,3
MOVSI TT,217400 ;16384.0 IN PDP10 MACHINE WORD
JRST FLOAT1
NVIDI: SKIPE FTVU ;LEAVES ANSWER IN TT
JRST NVIDI2
SKIPN NVDOPD
PUSHJ P,NVDOPN
NVIDI2: MOVE AR1,A ;GC PROTECT THIS
HRR D,B
HRL D,A
MOVE C,[-1,,D]
PUSHJ P,NVDPRE
JRST NVIDI3
SKIPN FTVU
JRST NVIDI1
HLRE TT,D ;ORDINARY CALL TO FAKETV
HRRES D
PUSHJ P,FAKETV
JRST NVIDI3
POPJ P,
NVIDI1: .IOT NVDC,D
SETZM NVDOPD
.CLOSE NVDC,
MOVE TT,D
POPJ P,
NVIDI3: PUSHJ P,NCONS
MOVEI B,QNVFIX ;REQUESTED POINTS OUT OF RANGE
PUSHJ P,XCONS ;ERROR ROUTINE TO PRODUCE ALTERNATIVE
SUB P,R70+1 ;CAUSES BREAK OUT OF NVID OR NVFIX
FAC [NON-EXISTENT VIDI POINT!]
NVDP4: MOVE F,TT
MOVEI R,0
ASHC R,22
DIV R,NVSCL
MOVEI TT,0
ASHC TT,22
DIV TT,NVSCL
NVDP3: JSP T,FIX1A ;GET A LIST OF THE TWO NUMBERS
PUSHJ P,NCONS ;([R] [TT])
MOVE B,A
MOVE TT,R
JSP T,FIX1A
JRST CONS
;;; IFN MOBIOF
NVDPRE: JFCL 8.,.+1
HLRZ A,(C) ;PRE-VIDISSECTING PROCESSING
JSP T,FXNV1
MOVE R,TT
IMUL TT,NVSCL
ADDI TT,400000 ;ROUNDING
SKIPL TT
CAML TT,[40000,,]
JRST NVDP1
JFCL 8.,NVDP1
HLLM TT,(C)
HRRZ A,(C)
JSP T,FXNV1
IMUL TT,NVSCL
ADDI TT,400000
SKIPL TT
CAML TT,[40000,,]
JRST NVDP2
JFCL 8.,NVDP2
HLRM TT,(C)
AOBJN C,NVDPRE
JRST POPJ1 ;SKIP ON SUCCESSFUL EXIT
NVDP1: HRRZ A,(C)
NVDP2: JSP T,FXNV1
JRST NVDP3
NVDPST: MOVE TT,(C) ;POST-VIDISSECTING PROCESSING
PUSHJ P,NVFX2
MOVEM A,(C)
AOBJN C,NVDPST
POPJ P,
NVFIX: PUSH P,B
PUSH P,A
NVFX1: PUSHJ P,NUMBERP
JUMPE A,NVFXB
POP P,A
POP P,B
PUSHJ P,NVIDI
NVFX2: TLNN TT,3 ;DIM CUTOFF, OR COUNTER OVERFLOW
TLZA TT,-1
MOVEI TT,40000 ;16384.
JRST FIX1
OPNGEN NVD,0
OPNGEN BVD,2,NVD
;;; IFN MOBIOF
NVFXB: MOVE A,(P) ;WHOLE BLOCK OF VALUES IN AN ARRAY
PUSHJ P,AREGET ;TO BE DISSECTTED
PUSH P,A
MOVE A,-2(P)
JSP T,FXNV1
LOCKI
MOVN AR1,TT
HRRZ C,(P)
HRRZ C,TTSAR(C)
HRL C,AR1 ;AOBJN PTR TO ARRAY ENTRIES FOR HACKING
MOVE AR1,C ;SAVE IN AR1
PUSHJ P,NVDPRE
JRST NVFXE3
SKIPE FTVU
JRST NVFXB2
SKIPN BVDOPD
PUSHJ P,BVDOPN
MOVE C,AR1
.IOT BVDC,AR1 ;FOR NLISP, WILL HAVE TO DO IT IN A
SETZM BVDOPD
.CLOSE BVDC,
NVFXB3: PUSHJ P,NVDPST
SUB P,R70+3
UNLOCKI
JRST FALSE
NVFXB2: HRRZ T,AR1 ;UPON ENTRY, CAN USE ARRAY PTR CALCULATED ABOVE
HLLZS AR1 ;-<NUMBER OF PTS TO VIDI> IN LH
TVFS1: HLRE TT,(T)
HRRE D,(T)
PUSH FXP,AR1
PUSHJ P,FAKETV ;MIGHT GC ARRAY SPACE
JRST NVFXE2
POP FXP,AR1
HRR T,(P)
HRR T,TTSAR(T)
ADD T,AR1
MOVEM TT,(T) ;PUT BACK VIDI VALUE
AOBJN AR1,[AOJA T,TVFS1]
SUBI T,-1(AR1) ;RESTORE T TO BE PTR TO ARRAY BEGIN
MOVNS AR1
HRL T,AR1
MOVE C,T
JRST NVFXB3
NVFXE2: SUB FXP,R70+1 ;FIX UP PDLS, AND GO TO ERROUT
NVFXE3: SUB P,R70+2
UNLOCKI
JRST NVIDI3
;;; IFN MOBIOF
NVSET: PUSH P,AR2A
LDB F,[251700,,ONVDC]
NVFIL: JUMPE A,NVCONF
JSP T,FXNV1
DPB TT,[100200,,F]
TRNN TT,4
TRZA F,10←10
TRO F,10←10
NVCONF: JUMPE B,NVRES
JSP T,FXNV2
MOVEM D,NVCFL
DPB D,[000200,,F]
NVRES: JUMPE C,NVDIM
JSP T,FXNV3
HRLZI T,40000
IDIVM T,R
MOVEM R,NVSCL
NVDIM: JUMPE AR1,NVXYZ
MOVE A,AR1
JSP T,FXNV1
MOVEM TT,NVDCL
DPB TT,[020300,,F]
NVXYZ: POP P,A
JUMPE A,NVST1
JSP T,FXNV1
JUMPN TT,.+2
TRZA F,340
TRO F,340
NVST1: DPB F,[251700,,ONVDC]
DPB F,[251700,,OBVDC]
SETZM NVDOPD
PUSH P,R70
MOVE TT,NVCFL
JSP T,FXCONS
PUSH P,A
HRLZI TT,40000
IDIV TT,NVSCL
JSP T,FIX1A
PUSH P,A
MOVE TT,NVDCL
JSP T,FXCONS
PUSH P,A
PUSH P,R70
MOVNI T,5
JRST LIST
;;; IFN MOBIOF
SUBTTL FAKE TV STUFF
;FUNCTIONS THAT ALLOW READING VIDISECTOR VALUES
; FROM A STORED IMAGE
SUBSIZ==64. ;SUB-PICTURE SIZE
VIDIS==4. ;NUMBER OF VIDI VALUES PER WORD
XWRDS==SUBSIZ/VIDIS
WRDBLK==SUBSIZ*XWRDS ;NUMBER WORDS IN A SUB-PICTURE
FRESL==16. ;STORED IMAGE HAS 1 OUT OF EVERY 16. POINTS
HFRESL==8.
;THIS CODE SETS UP THE MAXIMUM NUMBER OF BUFFERS USED BEFORE
;PAGING OUT ONE BLOCK AND READING ANOTHER IN OVER ITS BUFFER
SSFTVS:
IFE NSTAT,[
JSP T,FXNV2
MOVEM TT+1,MFTVBL
] ;END OF IFE NSTAT
IFN NSTAT,[
JSP T,FXNV1
MOVEM TT,MFTVBL
] ;END OF IFN NSTAT
JRST TRUE
FKTV2A: SUB FXP,R70+2
ADD TT,XLL
ADD TT+1,YLL
FKTV4: PUSHJ P,NVDP4
JRST FTVX ;NO SKIP IF POINTS OUT OF RANGE
;THIS ROUTINE WILL READ A VIDI VALUE FROM THE STORED IMAGE
; OPENED BY FTVOPN
; TT=X POSITION (OUT OF 16384.)
; D=Y POSITION
FAKETV: LOCKI
CAML TT,XLL
CAMLE TT,XUR
JRST FKTV4 ;NO SKIP IF POINTS OUT OF RANGE
CAML TT+1,YLL
CAMLE TT+1,YUR
JRST FKTV4 ;NO SKIP IF POINTS OUT OF RANGE
SUB TT,XLL
SUB TT+1,YLL
MOVE A,TT
IDIVI A,FRESL
CAIL B,HFRESL
AOS A ;CONVERT TO 1024. POINT FRAME SIZE
MOVE B,TT+1
IDIVI B,FRESL
CAIL C,HFRESL
AOS B
IDIVI B,SUBSIZ ;COMPUTE BLOCK NUMBER THAT CONTAINS POINT
PUSH FXP,C
IMUL B,XBLOKS
EXCH A,B
IDIVI B,SUBSIZ
PUSH FXP,C
ADDI A,1(B) ;MUST HAVE FEWER THAN 2←18. BLOKS
;;; IFN MOBIOF
CAMN A,CURBLK ;IS IT THE CURRENT BLOCK?
JRST FKTV1 ;YUP
CAMLE A,NBLOKS ;IS IT A REAL BLOCK?
JRST FKTV2A
PUSH FXP,A
PUSHJ P,FTGTBF
POP FXP,A
JUMPN B,FKTV1 ;IF BLOCK FOUND ON BLOKLIST, GO FTV1
IMULI A,WRDBLK ;IF NOT, THEN BUFFER IS READY FOR IOT INTO IT
.ACCESS FTVC,A ;GO TO BEGINNING OF DISK BLOCK
MOVNI A,WRDBLK
HRLZS A
HRR A,BUFFER
HRR A,TTSAR(A)
.IOT FTVC,A ;AND READ IT INTO CORE
FKTV1: MOVE B,NVDCL ;GET CURRENT DCL
CAMN B,ODCL
JRST FKTV3 ;NO CHANGE
MOVEM B,ODCL ;SET NEW LEVEL
SKIPE B
CAIN B,7
MOVEI B,1
IMULI B,100
MOVNS B
ADDI B,1300
MOVEM B,NVDK ;COMPUTE NEW DIM CUTOFF VALUE
FKTV3: POP FXP,B
POP FXP,C
VIDGET: HRRZ A,BUFFER ;THIS ROUTINE GETS A VIDI VALUE
HRRZ A,TTSAR(A) ;FROM THE CURRENT BLOCK
IMULI C,XWRDS ;B=X POSITION IN BLOCK
ADD A,C ;C=Y POSITION IN BLOCK
IDIVI B,VIDIS
ADD A,B ;ADDRESS OF WORD CONTAINING DESIRED BYTE
SUBI C,3
MOVMS C
IMULI C,110000 ;COMPUTE BYTE POINTER
ADDI C,1100 ;9 BITS PER BYTE
HRL A,C
LDB A,A ;GET BYTE
ADDI A,201
CAMLE A,NVDK
MOVE A,NVDK ;DIM CUTOFF HACK
LDB B,[60600,,A] ;RECREATE VIDI WORD FORMAT
ADDI B,224
MOVE C,A
TRZ C,777700 ;GET RID OF EXPONENT
ADDI C,100
FSC C,(B)
HLL A,C
MOVE TT,A
SETZB A,AR1
AOS (P) ;NORMAL EXIT FROM FAKETV SKIPS ONE
JRST FTVX
;;; IFN MOBIOF
;HERE WE GET THE TITLE ON THE FAKE TV FILE
SFTVTITLE: SKIPN FTVU
JRST FALSE
SKIPE CURBLK ;HEADER FOR FAKETV
PUSHJ P,PINIT ;MAKE SURE BLOCK 0 IS CURRENT
LOCKTOPOPJ
HRRZ R,BUFFER ;SAR WORD IN TT+2
HRRZ R,TTSAR(R)
SKIPN 3(R) ;GET HEADER DESCRIPTION AS LIST
JRST FALSE
ADDI R,3
HRLI R,440700
MOVEM R,CORBP
MOVEI A,SFTIT
SETZB B,MKNM3
JRST READ0A
SFTIT: ILDB A,CORBP
POPJ P,
PINIT: PUSH P,FTVU ;MAKE SURE BLOCK ZERO IS CURRENT
LOCKI
JRST SSFTV1
SSFTV: PUSHJ P,FTVOPN
SFTV: SKIPN FTVU
JRST FALSE
MOVE TT,XLL
MOVE TT+1,YLL
PUSHJ P,NVDP4
MOVE C,A
MOVE TT,XUR
MOVE TT+1,YUR
PUSHJ P,NVDP4
MOVE B,FTVU
PUSHJ P,CONS
MOVE B,C
JRST XCONS
;;; IFN MOBIOF
;;; THIS FUNCTION OPENS THE IMAGE FILE AND COMPUTES SOME NEEDED VALUES
FTOPNER: UNLOCKI
POP P,A
MOVEI B,QUREAD
PUSHJ P,XCONS
FAC [TV FILE NOT FOUND!]
FTVOPN: SETZM FTVU
SETZM FTVBL
SETZM NFTVBL
JUMPE A,CPOPJ
HRRZ T,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVEI T,6
PUSHJ P,UINITA
MOVE T,[UTIN,,FTVO]
BLT T,FTVO+2
SSFTV1: MOVEI A,0
PUSHJ P,FTGTBF ;GET A BUFFER REGION FOR BLOCK 0
JUMPN B,POP1J ;FINDABLE ONLY ON NON-INITIAL TRIES
.OPEN FTVC,FTVO
JRST FTOPNER
POP P,FTVU
SETZM CURBLK
SETOM ODCL ;FORCE RECOMPUTATION OF DIM CUTOFF VALUE
HRRZ A,BUFFER ;FIRST TIME THRU FAKETV
HRRZ A,TTSAR(A)
HRLI A,-2000
.IOT FTVC,A ;READ HEADER
HRRZ B,BUFFER ;XLL,,YLL
HRRZ B,TTSAR(B)
MOVE A,(B)
HLRZM A,XLL
HRRZM A,YLL
MOVE A,1(B) ;XUR,,YUR
HLRZM A,XUR
HRRZM A,YUR
MOVE A,XUR
SUB A,XLL
IDIVI A,SUBSIZ*FRESL
SKIPE B
AOS A ;ROUND OFF
MOVEM A,XBLOKS
MOVE A,YUR
SUB A,YLL
IDIVI A,SUBSIZ*FRESL
SKIPE B
AOS A
MOVEM A,YBLOKS
IMUL A,XBLOKS
MOVEM A,NBLOKS ;NUMBER OF SUB-PICTURES IN FILE
FTVX: SETZB B,C
UNLKPOPJ
;;; IFN MOBIOF
FTGTBF: PUSH P,A ;BLOCK NO. IN A
HRRZ B,FTVBL ;ALLOCATE A BUFFER AREA,
JUMPE B,FTGBF2
PUSHJ P,SAS1
JRST FTGBF1 ;SIGNAL IF DESIRED BLOCK IS FOUND
MOVEI B,TRUTH ;AND IS IN BUFFER AREA
FTGBF3: HRRZ A,(A) ;MAKE THE FOUND ENTRY CURRENT
MOVEM A,BUFFER
POP P,CURBLK
POPJ P,
FTGBF1: MOVE T,MFTVBL ;SO GRAB BUFFER AT FRONT OF QUEUE
CAMLE T,NFTVBL ;BRING TO END OF QUEUE, AND USE
JRST FTGBF2 ;IT FOR STORAGE OF DESIRED BLOCK
CAIG T,200
CAIGE T,1
JRST FTGBF6
MOVE A,FTVBL
HRRZ B,(A)
HLLOS NOQUIT
HRRM B,FTVBL ;CDR THE BLOCKS LIST
HLLZS (A)
HLRZ B,A ;POINTER TO CURRENT END OF BLOCKS LIST
HRRM A,(B) ;LIST IS NOW ROTATED ONE
HRLM A,FTVBL ;UPDATE POINTER TO END OF LIST
HLRZ A,(A)
MOVE B,(P) ;ROTATED BUFFER IS GRABBED FOR DESIRED BLOCK
HRLM B,(A)
FTGBF4: PUSHJ P,CZECHI
MOVEI B,NIL ;SIGNAL THAT DESIRED BLOCK NOT IN CORE YET
JRST FTGBF3 ;BUT A BUFFER HAS BEEN SET UP FOR IT
FTGBF6: MOVEI T,4
MOVEM T,MFTVBL
FTGBF2: MOVEI A,NIL
MOVEI TT,2000
PUSHJ P,MKFXAR
MOVE A,(P)
PUSHJ P,CONS
PUSHJ P,NCONS ;STRUCTURE OF BLOCKS LIST IS DOTTED PAIRS
HLRZ B,FTVBL ;WITH BLOCK NO. IN LH, ADDRESS OF SAR
HLLOS NOQUIT ;FOR BUFFER IN RH
HRLM A,FTVBL
SKIPN B
MOVEI B,FTVBL
HRRM A,(B) ;SPLICE IN NEW ENTRY AT LAST OF LIST
HLRZ A,(A)
AOS NFTVBL ;INFORM THAT ONE MORE BLOCK HAS BEEN TAKEN
JRST FTGBF4
;;; IFN MOBIOF
SUBTTL DISPLAY SLAVE ROUTINES
ZZ==P6+100
.XCREF ZZ
IRP A,,[DENABL,DFUNCTION,ERRLOC,ASTATE,ARYNUM,XARG,YARG,PENPOS,DBRITE
DSCALE,WRDCNT,MORFLG,DBUFFER]
A==ZZ
ZZ==ZZ+1
.XCREF ZZ
TERMIN ;ARGUNEMT CELLS
BFLNTH==1776-DBUFFER+P6
ZZ==1
.XCREF ZZ
IRP A,,[CREATE,DISADD,DISSUB,DFLUSH,DDISALINE,DCLEAR,DMOVE,DGET,DSEND
BLINK,UNBLINK,DCHANGE,DTEXT,DCOPY,WHERE,DPOINT,DNOOP,SHOWPEN,HIDEPEN
LINK,UNLINK,MOTION,DLISTINF,DLIST,DSET,DFRAME]
A==ZZ
ZZ=ZZ+1
.XCREF ZZ
TERMIN
DISPLAY: MOVEI R,DISADD ;FOR BACKTRACEING PURPOSES, THIS IS HERE
JRST DISP1
CN.Y: JSR CLZDIS
SKIPE DISON
SKIPN SIXOPD
JRST 2,@CNTROL
SETZM DENABL
SETZM DISON
JSR DISLEEP
JRST YF.MES
JRST 2,@CNTROL
CN.F: SKIPN DISON
SKIPN SIXOPD ;CAUSES SLAVE TO TRY TO GRAB 340
JRST 2,@CNTROL ;IF IT DOESN'T ALREADY HAVE IT
JSR CLZDIS
SETOM DENABL
JSR DISLEEP
JRST YF.MES
AOS DISON
JRST 2,@CNTROL
YF.MES: SAVE 40 UUOH
SAVEFX UUTSV UUTTSV UURSV
PUSHJ P,SAVX5
PUSHJ FXP,SAV5
STRT @DERR0(A)
JSP R,RSTR5
PUSHJ P,RSTX5
RSTRFX UURSV UUTTSV UUTSV
RSTR UUOH 40
JRST 2,@CNTROL
;;; IFN MOBIOF
;CLZDIS: 0
CLZDS1: SETZM DISPON ;(SETQ ↑N NIL)
SKIPE DISOPD
.CLOSE DISC, ;RELEASES DIS DEVICE IF JOB HAS IT
SETZM DISOPD
JRST 2,@CLZDIS
;DISLEEP: 0
DISLP1: MOVEI A,DNOOP ;USED AT INTERRUPT LEVEL, SO ONLY ACC A IS AVAILABLE
MOVEM A,DFUNCTION
AOS DISLEEP ;SKIPS IF SLAVE IS ALIVE AND WELL
MOVEI A,20. ;ELSE, NOSKIP AND LEAVE ERROR NUMBER IN A
SKIPL SIXOPD
MOVEI A,100. ;FOR PDP10, WAIT UP TO 3.3 SECONDS
MOVEM A,DISLP2 ;[FOR PDP6, UP TO .6 SECS] FOR SLAVE TO RESPOND
DISLP3: MOVEI A,1
.SLEEP A,
SKIPE A,ERRLOC
DISLP4: SOSA DISLEEP
SKIPN DFUNCTION
JRST 2,@DISLEEP
SOSL DISLP2
JRST DISLP3
JRST DISLP4
WAITSK: MOVEI F,1111. ;WAITS 1/30TH OF A SECOND, IN FAST MODE
XCT (T)
SOJN F,.-1
JUMPN F,2(T)
MOVEI F,30. ;JDC SAYS 10. ISN'T ENOUGH
SKIPL SIXOPD
MOVEI F,100. ;SKIP IF XCT'D SKIP WORKS WITHIN SOME
WASKP1: JUMPLE F,1(T) ;REASONABLE QUANTUM. BUT NO SKIP IF
MOVEI D,1 ;IT DOESN'T
.SLEEP D, ;THEN WAITS N 30THS OF A SECOND
WASKP2: XCT (T) ;IN SLOW MODE
SOJA F,WASKP1
JRST 2(T)
;;; IFN MOBIOF
CLSSIX: SKIPN SIXOPD
POPJ P,
LOCKI
SETZM DENABL
JSR DISLEEP
MOVEI A,NIL
SETZM DISON
SETZM SIXOPD
MOVE TT,[002000+SIXC,,<P6/2000>←9.] ;FLUSH PAGES FROM MY PAGE TABLE
.CBLK TT,
JFCL
.UCLOSE SIXC,
UNLKPOPJ
OPNSIX: SKIPE SIXOPD
POPJ P,
OP6D: LOCKI ;R<0 => SLAVE IS PDP6, >0 => PDP10
MOVNI R,1 ;R=0 => TRYING TO LOAD 6'S MEMORY AND START UP
.OPEN SIXC,[SIXBIT \ 'USR PDP6 \]
JRST OP10
OP6D2: MOVE TT,[002400+SIXC,,<400000+<P6/PAGSIZ>←11>]
.CBLK TT, ;MAKE PAGE 0 OF SIX INTO PAGE OF 10
.VALUE
OPD62A: MOVEM R,SIXOPD ;IF OPENING 6, THEN R=-1 WILL ALLOW SECOND TRY
OP6A: MOVEI TT,DCLEAR ;R = 0 SAYS TRY 10SLAVE IF NO RESPONSE
MOVEM TT,DFUNCTION
JSP T,WAITSK
SKIPE DFUNCTION
JRST OP6C
AOS DISON
SETZM MORFLG
SKIPL SIXOPD ;CLEARING WORRKED, SO SLAVE IS RUNNING WELL
UNLKPOPJ
JSP D,OPDSMS ;ANNOUNCE FACT, IF PDP6 WAS GRABBED
SETZ [SIXBIT \SLAVE GRABBED↑M!\]
UNLKPOPJ
;;; IFN MOBIOF
OP6C: JUMPGE R,OP6B ;ON FIRST FAILURE, TRY TO LOAD DISPLAY FROM DISC
.OPEN DSIC,[SIXBIT \ &SYSATSIGN6SLAVE\]
OP6C1: LERR DERR1
.RESET SIXC,
.CALL LSIXC ;LOAD UP SIX
.VALUE
MOVE TT,[JRST 2000] ;IF PDP6 IS RUNNING, IT WILL BE AT LOCATION 41
MOVEM TT,P6+41
.CLOSE DSIC,
AOJA R,OP6A
;;; IFN MOBIOF
OP10: JSP D,OPDSMS
[SIXBIT \NOT AVAILABLE!\]
JRST OPNTEN
OP6B: PUSHJ P,CLSSIX
JUMPN R,DERR0
JSP D,OPDSMS
[SIXBIT \NOT RUNNING!\]
OPNTEN: MOVE T,[6,,(SIXBIT \USR\)]
.SUSET [.RUNAME,,TT]
MOVE D,[SIXBIT \DSLAVE\]
.OPEN SIXC,T
.VALUE
.OPEN DSIC,[SIXBIT \ &SYSATSIGN10SLAV\]
JRST OP6C1
.CALL LSIXC
.VALUE
.CLOSE DSIC,
MOVE TT,[002400+SIXC,,<400000+<P6/PAGSIZ>←11>]
.CBLK TT, ;MAKE PAGE 0 OF SLAVE INTO PAGE OF 10
.VALUE
MOVEM F,XARG ;0 => 340 SLAVE, "TNM" => GT40 SLAVE
.USET SIXC,[.SUPC,,[2000]] ;LOC OF STARTING ADDRESS
.USET SIXC,[.SUSTP,,R70] ;BREATHE SOME LIFE INTO SLAVE
MOVEI R,1 ;R=1 SAYS 10SLAVE TAKEN
JRST OP6D2
OPDSMS: PUSHJ P,IOGBND
STRT [SIXBIT \↑MPDP6 !\]
STRT @(D)
SKIPL (D) ;SKIP FOLLOWING MSG IF ANNOUNCING PDP6 GRABBED
STRT [SIXBIT \ TRYING PDP10 SLAVE↑M!\]
PUSHJ P,UNBIND
JRST 1(D)
LSIXC: SETZ
SIXBIT \LOAD\
1000,,SIXC
401000,,DSIC
;;; IFN MOBIOF
CK6OPN: SKIPE SIXOPD ;QUICK CHECK FOR A WORKING SLAVE
JRST (T)
PUSH P,T
CK6NOPN: SKIPE SIXOPD ;LOOP AROUND THE FAIL-ACT UNTIL SLAVE IS OPENED
CCK6NOPN: POPJ P,CK6NOPN
DISNOPN: PUSH P,CCK6NOPN ;CAUSES RETRY OF TEST, AND EXIT THRU (T) IF WIN
%FAC DERR2
CSENDIT: SKIPN SIXOPD ;CHECK FIRST, THEN SENDIT
PUSHJ P,DISNOPN
MOVEM R,ARYNUM ;ARYNUM ARGUMENT IN R
SENDIT: MOVEM TT,DFUNCTION ;TT=FUNCTION NUMBER
SNDT1: AOS (P) ;SKIP IF WIN
SNDT1A: JSP T,WAITSK
SKIPE DFUNCTION
JRST SNDT2
ERRTST: MOVE TT,ARYNUM ;LEAVE ARYNUM IN TT
SKIPN D,ERRLOC ;MUST BE AN ERROR
POPJ P, ;ERRLOC=0 => NO ERRORS
ERTST1: JSP T,FIX1A
PUSHJ P,NCONS
MOVEI B,QDISPLAY
PUSHJ P,XCONS
SOS (P) ;NO SKIP IF LOSE
%FAC @DERR0(D)
SNDT2: SKIPE ERRLOC ;COME HERE WHEN THINGS HAVE BEEN GOING ON FOR A LONG TIME
JRST ERRTST
CAIE TT,DFRAME
CAIN TT,MOTION ;TT STILL HAS DFUNCTION IN IT
JRST SNDT1A ;MOTION IS ALLOWED TO GO ON FOR EVER
SETZB TT,D ;DEAD SLAVE - BOO HOO
JRST ERTST1
DISINI: AOJG T,DCLR1 ;LSUBR (0 . 2)
AOJL T,DISTMA
SETZ F,
JUMPN T,DCLR5
POP P,A
PUSHJ P,SIXMAK
HLRZ F,TT
PUSHJ P,CLSSIX
LOCKI
PUSHJ P,OPNTEN
JRST DCLR5A
DCLR5: PUSHJ P,OPNSIX ;GRAB SLAVE IF POSSIBLE
DCLR5A: POP P,A ;IF ARGUMENT GIVEN, THEN SET ASTATE
JSP T,FXNV1
DCLR3: JUMPL TT,.+2
CAILE TT,3 ;IF ARG NOT IN RANGE 0 - 3, THEN DONT CHANGE ASTATE
MOVE TT,ASTATE
EXCH TT,ASTATE
JRST FIX1
DCLR1: SKIPN SIXOPD
JRST DCLR4
MOVEI TT,DCLEAR ;OTHERWISE SIMPLY CLEAR AND INITIALIZE
MOVEM TT,DFUNCTION
JSP T,WAITSKP
SKIPE DFUNCTION
JRST SNDT2
JRST DCLR3
DCLR4: SETZ F,
PUSHJ P,OPNSIX
MOVE TT,ASTATE
JRST FIX1
;;; IFN MOBIOF
DISCREATE: MOVE TT,T
JSP T,CK6OPN
SETZM XARG
SETZM YARG
AOJG TT,DSCRT1
AOJN TT,DISTMA
POP P,C
POP P,B
PUSHJ P,DISXY
DSCRT1: MOVEI TT,CREATE
PUSHJ P,SENDIT
POPJ P, ;CUT OUT ON FAILURE
JRST FIX1
DISCOPY: MOVEI R,DCOPY
PUSHJ P,DISP1B
POPJ P, ;CUT OUT ON FAILURE
JRST FIX1
DISBLINK: MOVEI R,BLINK ;DISPLAY ALSO ENTERS HERE
DISP1: SKIPN B ;ENTER WITH FUN NUMBER IN R, LISP NUM FOR ARYNUM IN A
AOSA R ;DISADD ==> DISSUB, BLINK ==> UNBLINK, ETC.
DISP1C: MOVEI B,TRUTH
PUSHJ P,DISP1B
JFCL
JRST SPROG2
DISP1B: JSP T,FXNV1 ;SKIPS IF ACTION WINS
EXCH TT,R ;ARYNUM IN R, FUNCTION IN TT
DISXIT: PUSHJ P,CSENDIT
POPJ P, ;CUT OUT ON FAILURE
DISXT2: AOS (P)
POPJ P,
DISLINK: MOVEI R,LINK
JSP T,FXNV2
MOVE B,C
JRST DSMK1
DISMARK: MOVEI R,SHOWPEN
JSP T,FXNV2
HRLZ B,TT+1 ;IF 2ND ARG IS 0, THEN DO A UNMARK
DSMK1: JSP T,CK6OPN
MOVEM TT+1,XARG
JRST DISP1
DISFRAME: JSP T,FXNV1
JSP T,CK6OPN
MOVEM TT,WRDCNT
MOVEI TT,DFRAME
PUSHJ P,SENDIT
JFCL
JRST TRUE
;;; IFN MOBIOF
DISET: MOVEI F,1
MOVNI TT,2
JSP D,PPBSL
MOVEI R,DSET
JRST DAL2
DISFLUSH: MOVEI A,NIL
AOJG T,CLSSIX ;(DISFLUSH) SAYS TO FLUSH SLAVE
MOVN C,T
MOVEI R,DFLUSH ;(DISFLUSH N) SAYS FLUSH DISPLAY ITEM N
POP P,A
PUSHJ P,DISP1B
JFCL
SOJGE C,.-3
JRST TRUE
DISAPOINT: MOVEI R,DPOINT
JRST DAL0
DISALINE: MOVEI R,DDISALINE
DAL0: MOVNI TT,2
MOVEI F,3
JSP D,PPBSL
DAL1: POP P,B
POP P,A
MOVEI T,3
CAMN T,ASTATE
JRST DAL3
DAL4: JSP T,FXNV1
JSP T,FXNV2
DAL5: MOVEM TT,XARG
MOVEM TT+1,YARG
DAL2: POP P,A
JRST DISP1C
DAL3: JSP T,FLTSKP ;OOPS, POLAR COORDINATES
JSP T,DALMES
MOVE A,B
MOVE TT+1,TT
JSP T,FLTSKP
JSP T,DALMES
EXCH TT,TT+1
JRST DAL5
DISLOCATE: PUSHJ P,DISXY
MOVEI R,DMOVE
JRST DISP1C
DISXY: MOVEI F,XARG ;YARG=XARG+1
DISXY1: JSP T,CK6OPN
JSP T,FXNV2
MOVEM D,(F)
JSP T,FXNV3
MOVEM R,1(F)
POPJ P,
;;; IFN MOBIOF
DSCLUZ: SUB P,R70+3 ;LOSE AT DISCUSS
POPJ P,
DISCUSS: MOVEI F,4
MOVNI TT,1
JSP D,PPBSL
POP P,A
DSCS2: MOVEI TT,0
PUSH P,[DSCLUZ] ;JUST IN CASE MFGWT LOSES
JSP T,MFGWT ;SO NOW 6 IS LOCKED OUT OF BUFFER
SUB P,R70+1
HRROI R,DSCS1
MOVNI AR1,BFLNTH*BYTSWD
MOVE AR2A,[440700,,DBUFFER]
PUSHJ P,PRINTA
MOVEI TT,BFLNTH*BYTSWD(AR1) ;# OF BYTES INSRTED
MOVEM TT,WRDCNT
MOVEI R,DTEXT
SETOM MORFLG
JRST DAL1
DSCS1: AOSGE AR1 ;FUNCTION CALLED BY PRINC
IDPB A,AR2A
POPJ P,
PPBSL: SKIPN SIXOPD ;PROCESS OPTIONAL BSL AND PENPOS ARGS
PUSHJ P,DISNOPN ;F HOLDS NUMBER OF REQUIRED ARGS
ADD F,T ;TT HOLDS -<MAXIMUN NUMBER OF OPTIONAL ARGS>
CAML F,TT
CAILE F,0
DISTMA: LERR DERR3 ;WNA - DSLAVE
PPBSL1: JUMPE F,(D)
MOVE A,(P)
JUMPE A,PPBSL2
PUSHJ P,TYPEP
CAIN A,QLIST
JRST PPBSL3
AOJE TT,.+2 ;IF ONLY ONE OPTIONAL PERMITTED, IT MUST BE BSL
CAIE A,QFIXNUM
JRST PPBSL4
MOVE A,(P)
JSP T,FXNV1
MOVEM TT,PENPOS
PPBSL2: SUB P,[1,,1]
MOVEI TT,0
AOJA F,PPBSL1
PPBSL3: MOVE A,(P) ;PROCESS A BSL LIST
HLRZ A,(A)
JSP T,FXNV1
MOVEM TT,DBRITE
HRRZ A,@(P)
JUMPE A,PPBSL2
HLRZ A,(A)
JSP T,FXNV1
MOVEM TT,DSCALE
JRST PPBSL2
;;; IFN MOBIOF
DISCHANGE: MOVEI F,DBRITE ;DSCALE=DBRITE+1
PUSHJ P,DISXY1
MOVEI R,DCHANGE
JRST DISP1C
DISMOTION: PUSHJ P,DISXY
EXCH A,AR1
JSP T,FLTSKP
JSP T,IFLOAT
EXCH A,AR1
MOVEM TT,WRDCNT
MOVEI R,MOTION
PUSHJ P,DISP1B
POPJ P, ;CUT OUT ON FAILURE
MOVE D,[-2,,XARG]
JRST DSCB1A
DISLIST: AOJG T,DSLS1
JUMPN T,DISTMA
POP P,A
MOVEI R,DLISTINF
PUSHJ P,DISP1B
POPJ P, ;CUT OUT ON FAILURE
JRST DSLS2
DSLS1: MOVEI TT,DLIST
PUSHJ P,CSENDIT
POPJ P, ;CUT OUT ON FAILURE
DSLS2: MOVN D,XARG
JUMPE D,FALSE
HRLI D,DBUFFER
MOVSS D
JRST DSCB1A
DISCRIBE: MOVEI R,WHERE
PUSHJ P,DISP1B
POPJ P, ;CUT OUT ON FAILURE
MOVE D,[-10,,DBUFFER]
DSCB1A: MOVEI B,NIL
HLRE R,D
DSCB1: MOVE TT,(D)
JSP T,FIX1A
PUSH P,A
AOBJN D,DSCB1
MOVE T,R
JRST LIST
MFGWT: SKIPN MORFLG ;MORFLG WAIT - I.E., WAIT UNTIL MORFLG GOES TO ZERO
JRST (T)
PUSH P,T
JSP T,WAITSK
SKIPE MORFLG
JRST .+2
POPJ P,
SUB P,R70+1
AOS (P)
JRST SNDT2
;;; IFN MOBIOF
DISGORGE: JSP T,CK6OPN
JSP T,MFGWT
SETOM MORFLG
JSP T,FXNV1
MOVEM TT,ARYNUM
HRLOI R,DSEND
HLRZM R,DFUNCTION
JSP T,MFGWT
MOVE TT,WRDCNT
MOVEI A,NIL
PUSHJ P,MKFXAR
HRRZ R,TTSAR(B)
MOVE TT,WRDCNT
DSGRG1: JSP T,MFGWT
CAIG TT,BFLNTH
SKIPA F,TT
MOVEI F,BFLNTH
ADDI F,-1(R)
HRLI R,DBUFFER
BLT R,(F)
MOVEI R,1(F)
HRREI TT,-BFLNTH(TT)
JUMPLE TT,CPOPJ
SETOM MORFLG
JRST DSGRG1
DISGOBBLE: PUSHJ P,SARGET
JSP T,MFGWT
MOVE R,ASAR(A)
HLRE TT,-1(R)
HRRZ R,-1(R)
MOVNS TT
MOVEM TT,WRDCNT
MOVEI F,DGET
MOVEM F,DFUNCTION
DSGBL1: CAIG TT,BFLNTH
SKIPA F,TT
MOVEI F,BFLNTH
MOVEI T,DBUFFER
HRL T,R
ADD R,F
ADDI F,DBUFFER-1
BLT T,(F)
HRREI TT,-BFLNTH(TT)
SETOM MORFLG
JSP T,MFGWT
JUMPG TT,DSGBL1
PUSHJ P,SNDT1
POPJ P, ;CUT OUT ON FAILURE
JRST FIX1
;;; IFN MOBIOF
PLOTLIST: MOVEI TT,0
AOJE T,PLTL1
AOJN T,PLTL2
POP P,A ;THE CHAR PLOTTED TO REPRESENT A SINGLE SCOPE POINT
MOVEM P,PLTTBF ;MAY BE CHANGED BY GIVING PLOTLIST
HRROI R,.+2 ;A SECOND ARGUMENT
JRST PRINTA
MOVE P,PLTTBF
MOVEI TT,0
DPB A,[110700,,TT]
PLTL1: POP P,PLTLST
TDOA TT,[PLTLST,,767]
PLOT: JSP T,FXNV1
PLOTC: JUMPE TT,UNPLOT
SKIPN IPLOPD
PUSHJ P,IPLOPN
.IOT IPLC,TT
JRST TRUE
UNPLOT: .CLOSE IPLC,
SETZM IPLOPD
JRST FALSE
PLOTTEXT: PUSH P,A
PUSHJ P,PLT2
POP P,A
HRROI R,PLT1
PUSHJ P,PRINTA
MOVE TT,PLTTBF
JRST PLOTC
PLT1: IDPB A,PLTTBP
MOVE A,PLTTBP
TLNE A,760000
POPJ P,
MOVE TT,PLTTBF
PUSHJ P,PLOTC
PLT2: MOVE A,[440700,,PLTTBF]
MOVEM A,PLTTBP
SETZM PLTTBF
POPJ P,
NEXTPLOT: MOVE TT,[034130,,77] ;PENUP AND NORMAL ORIENTATION
PUSHJ P,PLOTC
MOVE TT,[<1,,1>\<2300.,,0>←2] ;MOVE TO Y=0, X=2300.
PUSHJ P,PLOTC
MOVE TT,[<0,,1>\<0,,0>←2] ;DEFINE ORIGIN (0,0)
PUSHJ P,PLOTC
MOVE TT,[450000,,77] ;RESTORE ORIENTATION
JRST PLOTC
PLTL2: LERR [SIXBIT \WNA - PLOTLIST!\]
OPNGEN IPL,5
PGTOP MIO,[MOBYIO PACKAGE]
;;@ END OF MOBYIO 13
]
;;@ PRINT 113 PRINT AND FILE-HANDLING FUNCTIONS
SUBTTL FUNNY PRINTING ROUTINES
PGBOT PRT
IFE D10\QIO,[
RCPSBK: SETZ
SIXBIT \RCPOS\
1000,,TYIC
402000,,D
] ;END OF IFE D10\QIO
.NOPOINT: PUSHJ P,NOTNOT
HRRZM A,V.NOPOINT
POPJ P,
CTY: PUSHJ P,TYOI ;THIS IS ALWAYS DONE BY A XCT "Q,CTY - FOR RANDOM Q.
TYOI: PUSH P,A ; USEFUL MAINLY BECAUSE IT SAVES A. WARNING!!!
MOVE A,-1(P) ; THIS CODE IS VERY HACKISH, DEPENDENT ON THE OPCODE
LDB A,[270600,,-1(A)] ; OF XCT (256). THIS ONLY WORKS FOR ASCII
PUSHJ P,(R) ; CHARS IN THE RANGE 40-57. THUS Q MUST BE AMONG
JRST POPAJ ; [ !"#$%&'()*+,-./] (THE BRACKETS ARE META-CHARS!)
;;; XCT N,CTYP
;;; CAUSES THE N'TH CHARACTER IN TYO1TB TO GET PRINTED VIA
;;; THE ROUTINE IN R. SYMBOLS ARE DEFINED FOR THESE XCT'S.
CTYP: PUSHJ P,TYO1C
TYO1C: PUSH P,A
HRRZ A,-1(P)
LDB A,[270400,,-1(A)]
MOVE A,TYO1TB(A)
PUSHJ P,(R)
JRST POPAJ
TYO1TB:
IRP X,,[#,(,),+,-,.,/,|,:,;, ,←,E,⊃,.]Z,,[NMBR,LPAR,RPAR,POS
NEG,DOT,SLSH,VBAR,CLN,SEMI,SPC,BAK,E,CTLQ,DCML]
%!Z!%=XCT .IRPCNT,CTYP
"X
TERMIN
IFG .-TYO1TB-20, WARN [TOO MANY TYO1TB CHARACTERS]
IFE QIO,[
SUBTTL OLD I/O TYO FUNCTION
%TYO: JSP T,FXNV1
MOVE A,TT
ANDI A,177
PUSH P,CTRUE
TYO: JUMPL A,TYOLA
CAIN A,15 ;CLOBBERS D - - SAVES ALL OTHERS
JRST TYOCR
TYO2: MOVE D,@VCHRCT
SOJL D,TYTB1
CAIN A,11 ;TAB
JRST TYOTAB
TYO1: ADDI D,IN0
MOVEM D,VCHRCT
CAIN A,"/
JRST TYO1A
TYO1B: SETZM LTYOC
TYO3:
IFN USELESS,[
SKIPGE TYOSW ;TTY-ONLY CHARS DON'T GO TO FILES!
JRST TYO7
] ;END OF IFN USELESS
IFN MOBIOF,[
SKIPE DISPON
PUSHJ P,DCHAR
] ;END OF IFN MOBIOF
10% SKIPLE LPTON
10% PUSHJ P,LPTCHAR
SKIPE TAPWRT
PUSHJ P,UTYO
IFN USELESS, TYO7: SKIPG TYOSW ;FILE-ONLY CHARS DON'T GO TO TTY!
SKIPE TTYOFF
POPJ P,
JRST TTYTYO
TYO1A: AOS D,LTYOC
SOJE D,TYO3
JRST TYO1B
TYOLA: MOVE D,@VCHRCT ;TYO LOOKAHEAD - RH OF A HAS DESIRED NUMBER OF
CAIGE D,(A) ; CHARS FOR AN OBJECT ABOUT TO BE PRINTED
CAMN D,@VLINEL ;IF ALREADY AT BEGINNING OF LINE, CAN'T WIN ANY BETTER
POPJ P,
PUSHJ P,ICR ;NEED TO OUTPUT A CR SO ATOM WILL FIT
JFCL
POPJ P,
STRTYO: MOVE A,TT
JRST TYO
;;; IFE QIO
TYOCR: MOVE D,@VLINEL ;LINEL HAD DAMNED WELL BETTER BE A FIXNUM,
CAIGE D,XHINUM ; AND BETWEEN 8 AND HIGHEST NLISP INUM
CAIGE D,10
JSP D,LINELR
JRST TYO1
TYOTAB: SUB D,@VLINEL
ORCMI D,7
MOVEI D,11(D)
SUB D,@VCHRCT
MOVNS D
JUMPG D,TYO1
MOVEM A,LTYOC
MOVEI D,IN0
MOVEM D,VCHRCT
TYTB1: PUSHJ P,ICR
JRST TYO1B
JRST TYO2
;;; SKIPS IF THE TERPRI IS ACTUALLY DONE. NO SKIP IF SUPPRESSSED
ICR: SKIPE V%TERPRI
POPJ P,
MOVE D,@VLINEL ;LINEL HAD DAMNED WELL BETTER BE A FIXNUM,
CAIGE D,XHINUM ; AND BETWEEN 8 AND HIGHEST NLISP INUM
CAIGE D,10
JSP D,LINELR
PUSH FXP,TT
MOVEI TT,LRCT-1
MOVE D,VREADTABLE
HLRZ TT,@TTSAR(D)
IOR TT,LTYOC
JUMPN TT,RSTX1
POP FXP,TT
AOS (P)
JRST ITERPRI
IFN MOBIOF,[
DCHAR: PUSH P,[.IOT DISC,A]
SKIPE DISOPD
JRST CHARCOM ;SIMPLE, UNCOMPLICATED .IOT TO DISC
SKIPE DISON
SKIPN SIXOPD
JRST DCHAR1
SETZM DENABL ;SLAVE HAS 340 - MAKE IT RELEASE IT FIRST
PUSH P,A
JSR DISLEEP
JRST DERR0(A)
POP P,A
DCHAR1: SETZM DISON ;THEN OPEN 340 AS DIS DEVICE
PUSHJ P,DISOPN
JRST CHARCOM
OPNGEN DIS,1
] ;END OF IFN MOBYIO
;;; IFE QIO
IFN ITS,[
LPTCHAR: SKIPN LPTOPD
PUSHJ P,LPTOPN
PUSH P,[.IOT LPTC,A]
JRST CHARCOM
OPNGEN LPT,1
] ;END OF IFN ITS
UTYO: PUSH P,[PUSHJ P,UTTYO] ;OUTPUT TO UTAPE [OR OTHER AUXILLARY DEVICE]
CHARCOM: XCT (P)
CAIE A,15
JRST POP1J
MOVEI A,12
XCT (P)
MOVEI A,15
JRST POP1J
UTOER2: SETOM UTOBYT
UNLOCKI
PUSH P,[UTOER3]
PUSH P,A
PUSH P,CPOPAJ
JRST UTOER1
UTOER3: SKIPG UTOBYT
JRST UTOER4
MOVEI D,TRUTH
MOVEM D,TAPWRT
UTTYO: SOSGE UTOBYT
JRST .+3
IDPB A,UTOBP
POPJ P,
LOCKI
SKIPL UTOBYT ;INTERVENING INTERRUPT BETWEEN SOSGE AND LOCKI
.VALUE
SKIPN UTOOPD
JRST UTOER2
10% MOVE D,[-UTBSIZ,,UTOB]
10% .IOT UTOC,D
10$ OUT UTOC,
10$ JRST UTTYO2
10$ D10WF: LERR [SIXBIT \OUTPUT FAILURE!\]
10% PUSHJ P,UTOINT
UTTYO2: UNLOCKI
JRST UTTYO
UTOER4: MOVSI D,(JFCL) ;CONVERT PUSHJ P,UTTYO ON PDL INTO
MOVEM D,-1(P) ;HARMLESS JFCL, JUST IN CASE THERE IS CR-LF
POPJ P,
IFN ITS,[
UTOINT: MOVE D,UTOIBP
MOVEM D,UTOBP
MOVEI D,UTBSIZ*BYTSWD
MOVEM D,UTOBYT
POPJ P,
UTOIBP: 440700,,UTOB
] ;END OF IFN ITS
;;; IFE QIO
TTYTYO:
IFN D10,[
CAIN A,33 ;DEC LOSES ALT MODES
JRST OUT$
OUTCHR A ;SO OUTPUT CHARACTER
CAIN A,↑M ;IF IT WAS A CR,
OUTCHR .+1 ; OUTPUT A LF ALSO
POPJ P,↑J ;MIGHT AS WELL HIDE THE LF IN A POPJ
] ;END OF IFN D10
IFN ITS,[
CAIN A,↑P ;ITS LOSES ON CTRL/P
JRST TYOCP
.IOT TYOC,A
TTYTY1: SKIPE SPP
CAIE A,↑M
POPJ P,
SKIPN SRNLN1
POPJ P,
.CALL RCPSBK ;AFTER TYOING A CR, AND BEING IN DISPLAY PAUSE MODE
.VALUE ;READ CURSOR POSITION TO SEE IF WE SHOULD PAUSE
HLRZS D
CAMGE D,SRNLN1
POPJ P,
MOVEI D,[ASCIZ \⊂S--PAUSE-- HIT ↑U TO CONTINUE\]
SETZM PAUSFL
PUSHJ P,SRNTYP
SKIPN PAUSFL
.HANG
MOVEI D,PAUSCLR
SRNTYP: HRLI D,440700 ;OUTPUT STRING OF CHARS TO TTY
PUSH FXP,D ;USES ONLY D, WHICH POINTS TO CHARS
SNTP0: ILDB D,(FXP) ;MUST SAVE AR2A AND R, EITHER OF
JUMPE D,PX1J ; WHICH MAY CONTAIN THE CHARS!
CAIN D,↑P ;MUST BE VERY CIRCUMSPECT ABOUT ↑P
JRST SNTP1 ; - INTERRUPTING BETWEEN ↑P AND NEXT
.IOT TYOC,D ; CHAR(S) COULD CAUSE AN I/O SCREW
JRST SNTP0
SNTP1: HLLOS NOQUIT ;SO TURN ON NOQUIT
.IOT TYOC,D ;OUTPUT THE ↑P
ILDB D,(FXP)
.IOT TYOC,D ;OUTPUT NEXT CHAR
CAIE D,"H ;IF WAS H OR V, ↑P EXPECTS YET
CAIN D,"V ; ANOTHER CHAR
JRST SNTP2
SNTP3: HLLZS NOQUIT ;SO RELEASE NOQUIT
SKIPE INTFLG ;MAYBE CHECK FOR INTERRUPTS
PUSHJ P,CHECKI
JRST SNTP0
SNTP2: ILDB D,(FXP) ;HANDLE CASE OF ↑P H OR ↑P V
.IOT TYOC,D
JRST SNTP3
TYOCP: PUSHJ P,ECOCNP
JRST TTYTY1
PAUSCLR: ASCIB [⊂R⊂)
]
] ;END OF IFN ITS
] ;END OF IFE QIO
IFN QIO,[
SUBTTL NEWIO TYO FUNCTION AND RELATED ROUTINES
;;; CALLED BY FUNCTIONS LIKE PRINT WHICH TAKE AN ARG AND
;;; AN OPTIONAL ASCII OUTPUT FILE ARRAY. DOES ARGS CHECKING
;;; AND SETS UP AR1 WITH THE CORRECT OUTPUT FILE(S).
;;; IF ONE ARG IS GIVEN AND THERE ARE NO FILES TO OUTPUT TO
;;; (↑W IS NON-NIL, AND EITHER ↑R OR OUTFILES IS NIL),
;;; THEN A POPJ IS DONE, RETURNING FOR THE CALLING FUNCTION.
;;; LEFT HALF BITS IN AR1:
;;; 400000 RH OF AR1 HAS SINGLE FILE ARRAY (ELSE LIST)
;;; 200000 DO *NOT* OUTPUT TO TTY AS WELL
;;; CALLED BY:
;;; JSP F,PRNARG
;;; XXX,,QPRINT ;ATOM FOR WNA ERROR
;;; XXX IS TYPICALLY JFCL. IF XXX IS NEGATIVE, THE RETURN VALUE
;;; FOR THE FUNCTION IS NIL INSTEAD OF T.
PRNARG: AOJN T,PRNAR2
POP P,A
PRNAR$: SAVE AR1 AR2A CPNAGX
PRNAR0: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
JUMPN AR1,PRNAR3
SKIPE TTYOFF
JRST PRNAR8
PRNAR3: TRNE AR1,-1
PUSHJ P,MPFLOK
JRST 1(F)
PRNAR2: AOJN T,PRNAR9
MOVE A,-1(P)
MOVEM AR1,-1(P)
EXCH AR2A,(P)
PUSH P,CPNAGX
SKIPN AR1,AR2A
JRST PRNAR0
JSP T,PRNARK
JRST PRNAR6
PRNAR5: TLO AR1,600000
JRST 1(F)
PRNAR6: TLO AR1,200000
JRST PRNAR3
PRNAR8: SKIPGE (F)
JRST FALSE
JRST TRUE
PRNAR9: HRRZ D,(F)
JRST S2WNAL
PNAGX: RSTR AR2A AR1
CPNAGX: POPJ P,PNAGX
MPFLOK: PUSH P,AR1 ;MUST PRESERVE LH OF AR1
MOVEI AR2A,(AR1)
MPFLO1: JUMPE AR2A,MPFLO2
HLRZ AR1,(AR2A)
JSP T,PRNARK
JRST PRNRK0
HRRZ AR2A,(AR2A)
JRST MPFLO1
MPFLO2: POP P,AR1
POPJ P,
PRNARK: CAIN AR1,TRUTH ;ARG CHECK FOR PRNARG
HRRZ AR1,V%TYO
JSP TT,XFILEP ;MUST BE FILE ARRAY
JRST (T)
MOVE TT,TTSAR(AR1)
TLNE TT,TTS.IO ;MUST BE OUTPUT FILE
TLNE TT,TTS<BN+CL> ;MUST NOT BE CLOSED, NOR BINARY
JRST PRNRK0
JRST 1(T)
PRNRK0: ADDI T,1 ;SO CALL THE SLOW "ATOFOK" FOR ERROR MSG
PUSH P,T
PUSHJ P,ATOFOK
UNLKPOPJ
;;; IFN QIO
DEFINE .5LOCKI ;HALF-LOCK INHIBIT - SEE CHNINT
PUSH FXP,INHIBIT
HRROS INHIBIT
TERMIN
DEFINE .5LKTOPOPJ
PUSH P,CINTREL
.5LOCKI
TERMIN
TYO$: JSP F,PRNAR$
QTYO$
JRST %TYO1
%TYO: JSP F,PRNARG
JFCL Q%TYO
%TYO1: JSP T,GTRDTB
PUSHJ P,TYO1
JRST TRUE
TYO: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES ;TEMP ??
$TYO: PUSH FXP,T ;MUST SAVE R FOR PRINT
PUSH FXP,TT
PUSH P,[PXTTTJ] ;TEMP INTERFACE CRAP
JSP T,GTRDTB
TYOPR: SKIPA TT,A
TYO1: JSP F,TYOARG
;AT THIS POINT: CHAR IN TT, FILE(S) IN AR1, READTABLE IN AR2A
;MUST SAVE A,B,C,AR1
TYO6: .5LKTOPOPJ
STRTYO: JUMPGE AR1,TYO5
TLNN AR1,200000
SKIPE TTYOFF
JRST TYO6A
SKIPLE TYOSW
JRST TYO6A
PUSH P,AR1
HRRZ AR1,V%TYO
PUSHJ P,TYOF
POP P,AR1
TYO6A: MOVEI T,(AR1)
CAIN T,TRUTH
HRR AR1,V%TYO
SKIPGE TYOSW
POPJ P,
JRST TYOF
TYO5:
REPEAT 2, PUSH P,AR1
HRRZS -1(P)
TLNN AR1,200000
SKIPE TTYOFF
JRST TYO2
HRRZ AR1,V%TYO
SKIPG TYOSW
PUSHJ P,TYOF
TYO2: SKIPL TYOSW
TYO2A: SKIPN AR1,-1(P)
JRST TYO4
HLRZ AR1,(AR1)
CAIN AR1,TRUTH
HRRZ AR1,V%TYO
PUSHJ P,TYOF
HRRZ AR1,@-1(P)
MOVEM AR1,-1(P)
JRST TYO2A
TYO4: POP P,AR1 ;PRESERVE AR1
JRST POP1J
TYOARG: JSP T,FXNV1
10% TDNN TT,[777777,,770000] ;UP TO 12. BITS OKAY
10$ TDNN TT,[777777,,777600] ;UP TO 7 BITS OKAY
JRST (F)
JRST TYOAGE
;;; IFN QIO
;;; TYO ONE CHARACTER TO ONE FILE. MUST PRESERVE AR1,AR2A
;;; USER INTERRUPTS LOCKED OUT. (??)
;;; FILE ARRAY IN AR1.
;;; READTABLE IN AR2A.
;;; CHARACTER IN TT (MUST BE PRESERVED).
;;; TYOF HANDLES ALL CHARPOS, LINENUM, AND PAGENUM PROCESSING,
;;; CONTROL CHARACTERS, SAIL MODE OUTPUT, ETC.
;;; ALL CR'S NOT FOLLOWED BY LF'S HAVE LF'S SUPPLIED FOR THEM.
;;; MUST SAVE R FOR PRINT.
TYOFA: MOVE TT,A
TYOFIL: .5LKTOPOPJ
TYOF: MOVE T,TTSAR(AR1)
TYOF0: TRNN AR1,-1
JRST TYOFE
JUMPL TT,TYOF7 ;NEGATIVE => FORMAT INFO
SKIPGE ATO.LC(T)
PUSHJ P,TYOFXL
CAIN TT,177 ;RUBOUT HAS NO PRINT WIDTH
JRST TYOF4
CAIGE TT,40 ;CONTROL CHARACTERS HAVE WIDTH
JRST TYOF2 ; OF 1 OR 2, OR ELSE ARE FUNNY
TYOF0D: AOS D,AT.CHS(T) ;INCREMENT CHARPOS
SKIPE ATO.LC(T) ;SKIP UNLESS LAST CHAR WAS /
JRST TYOF0G
SKIPLE FO.LNL(T) ;ZERO OR NEGATIVE LINEL => INFINITY
TLNE T,TTS<IM> .SEE STERPRI
JRST TYOF0E ;FOR IMAGE OUTPUT, NO EXTRA CHARS
CAMLE D,FO.LNL(T)
SKIPE V%TERPRI
JRST TYOF0E
HRLM TT,(P) ;NEW LINE NEEDED BEFORE THIS CHAR
MOVEI TT,↑M ;BECAUSE OF AUTO-TERPRI
PUSHJ P,TYOF4
PUSHJ P,TYOFXL
MOVEI TT,1
MOVEM TT,AT.CHS(T) ;SO THIS CHAR WILL BE AT CHARPOS 1
HLRZ TT,(P)
TYOF0E: MOVE D,@TTSAR(AR2A) ;GET READTABLE ENTRY FOR THIS
TLNE D,2000 ;IF THIS IS A /, SET FLAG
HLLOS ATO.LC(T) ; FOR NEXT TIME AROUND
JRST TYOF4
TYOF0G: SETZM ATO.LC(T) ;RESET / FLAG
JRST TYOF4 ;OUTPUT CHAR, IGNORING LINEL
TYOF2: CAIG TT,↑M ;FOUND CONTROL CHAR
CAIGE TT,↑H
JRST TYOF3 ;REGULAR CONTROL CHAR
JRST @.+1-↑H(TT) ;FORMAT EFFECTOR - PECULIAR
TYOFBS ;↑H BACKSPACE
TYOFTB ;↑I TAB
TYOFLF ;↑J LINE FEED
TYOF3 ;↑K <NOT REALLY FORMAT CHAR>
TYOFFF ;↑L FORM FEED
TYOFCR ;↑M CARRIAGE RETURN
TYOFXL: SETZM ATO.LC(T) ;LINE FEED NEEDED BEFORE THIS CHAR
CAIE TT,↑J ;SKIPE OUT IF THIS CHAR IS LF
TLNE T,TTS<IM> ;DON'T GENERATE LF FOR IMAGE FILE
POPJ P,
HRLM TT,(P)
MOVEI TT,↑J
PUSHJ P,TYOFLF
HLRZ TT,(P)
POPJ P,
TYOFE: EXCH A,AR1
%WTA [SIXBIT \NOT A FILE - TYO!\]
TYOF3: CAIN TT,33 ;ALTMODES ARE ALWAYS 1 WIDE
JRST TYOF0D
MOVE D,F.MODE(T) ;RANDOM CONTROL CHAR
TLNN D,FBT<SA> ;SKIP IF SAIL MODE FILE
AOS AT.CHS(T) ;OTHERWISE CONTROL CHARS ARE 2 WIDE
JRST TYOF0D
TYOFBS: SKIPLE AT.CHS(T) ;BACKSPACE - UNLESS AGAINST LEFT MARGIN,
SOS AT.CHS(T) ; DECREMENT CHARPOS
SETZM ATO.LC(T) ;CLEAR / FLAG
JRST TYOF4
TYOFTB: MOVEI D,7 ;TAB FOUND - JUMP TO NEXT
IORM D,AT.CHS(T) ;MULTIPLE-OF-8 CHARPOS
JRST TYOF0D
TYOFLF: AOS D,AT.LNN(T) ;INCREMENT LINENUM
SKIPLE FO.PGL(T) ;ZERO PAGEL => INFINITY
CAMGE D,FO.PGL(T) ;SKIP IF OVER PAGE LENGTH
JRST TYOF4
TYOFFF: SETZM AT.LNN(T) ;ZERO LINE NUMBER
AOS AT.PGN(T) ;INCREMENT PAGE NUMBER
SKIPN FO.EOP(T) ;IF IT HAS AN ENDPAGEFN, THEN
JRST TYOF4 ; WANT TO GIVE USER INTERRUPT
MOVEI D,200000+2*FO.EOP+1
HRLI D,(AR1)
CAIN TT,↑J ;MAYBE ENDPAGEFN SHOULD KNOW
HRRZS INHIBIT ; WHETHER LF OR FF??
PUSHJ P,UINT
CAIE TT,↑J
POPJ P,
HRROS INHIBIT
JRST TYOF4
TYOF7: SKIPLE FO.LNL(T) ;INFINITE LINEL
TLNE T,TTS<IM> ; OR IMAGE MODE TTY
POPJ P, ; => IGNORE FORMAT DATA
SKIPN V%TERPRI
SKIPN AT.CHS(T) ;CAN'T DO ANY BETTER THAN TO BE
POPJ P, ; AT THE BEGINNING OF A LINE
MOVEI D,(TT)
ADD D,AT.CHS(T)
CAMG D,FO.LNL(T)
POPJ P,
SETZM AT.CHS(T)
PUSH FXP,TT
MOVEI TT,↑M ;IF TOO LONG, DO AN AUTO-TERPRI
PUSHJ P,TYOFCR
POP FXP,TT
POPJ P,
TYOFCR: SETZM AT.CHS(T) ;CR - SET CHARPOS TO ZERO
PUSHJ P,TYOF4
SETOM ATO.LC(T) ;SET LF FLAG (MUSTN'T DO UNTIL AFTER IOT
POPJ P, ; OF CR BECAUSE A **MORE** MIGHT OCCUR)
TYOF4: TLNE T,TTS<TY>
JRST TYOF4C
TYOF6:
TYOF4A: SKIPL F.MODE(T) .SEE FBT.CM
JRST TYOF5
TYIF1: MOVE D,F.CHAN(T) ;CHARMODE (UNIT MODE)
LSH D,27 ;TYI USES THIS CODE TOO (SAVES F)
IOR D,[.IOT TT]
SPECPRO INTTYX
TYOTYI: XCT D
NOPRO
SKIPL F.FPOS(T) ;UNIT ASCII COUNTS FILEPOS BY CHARS
AOS F.FPOS(T)
POPJ P,
INTTYR: HRROS INHIBIT .SEE IWAIT ;COME HERE AFTER INTERRUPT
MOVE T,TTSAR(AR1) ;FILE ARRAY MAY HAVE MOVED
JRST TYOTYI
TYOF5: IDPB TT,AB.BP(T)
SOSLE AB.CNT(T) ;BLOCK MODE
POPJ P,
HRLM TT,(P)
MOVE TT,T
PUSHJ P,IFORCE
TYOF5X: MOVE T,TTSAR(AR1)
HLRZ TT,(P)
POPJ P,
TYOF4C: TLNE T,TTS<IM> ;DO NOT HACK THIS FOR IMAGE MODE
JRST TYOF4A
CAIN TT,↑C ;↑C IS NORMALLY USED FOR PADDING
JRST TYOF4H ; AND SO IS IGNORED. ↑P IS THE
CAIE TT,↑P ; DISPLAY ESCAPE CODE. BOTH MUST
JRST TYOF4A ; BE TREATED SPECIALLY.
SKIPA D,["P] ;OUTPUT ↑P AS ↑P P
TYOF4H: MOVEI D,"Q ;OUTPUT ↑C AS ↑P Q
HRLM TT,(P)
PUSH FXP,D
SKIPGE F.MODE(T)
JRST TYOF4J
MOVE TT,AB.CNT(T) ;FOR BLOCK MODE, BE PARANOID
CAIGE T,2 ; ABOUT SPLITTING A ↑P-CODE
PUSHJ P,IFORCE ; ACROSS A BLOCK BOUNDARY
TYOF4J: MOVE T,TTSAR(AR1)
MOVEI TT,↑P
PUSHJ P,TYOF4A
MOVE T,TTSAR(AR1)
POP FXP,TT
PUSHJ P,TYOF4A
JRST TYOF5X
] ;END OF IFN QIO
SUBTTL TERPRI FUNCTION
IFE QIO,[
%TERPRI:
TERPRI: MOVEI A,NIL ;SUBR 0
ITERPRI: PUSH P,A
MOVEI A,↑M
CTYO: PUSHJ P,TYO
JRST POPAJ
] ;END OF IFE QIO
IFN QIO,[
%TERPRI: JUMPN T,.+3
PUSH P,R70
MOVNI T,1
PUSH P,(P) ;EVEN THOUGH LSUBR (0 . 1)
SOS T ;PRETEND TO BE (1 . 2) FOR PRNARG'S SAKE
JSP F,PRNARG ;PRNARG MAY DO A POPJ FOR US - BEWARE!
400000,,Q%TERPRI ;BIT 4.9 => RETURN VALUE IS NIL
JRST TERP1
TRP$: JSP F,PRNAR$
400000,,QTRP$
JRST TERP1
TERPRI: SKIPE AR1,TAPWRT ;1/4-INTERNAL TERPRI
HRRZ AR1,VOUTFILES
TERP1: JSP T,GTRDTB ;SEMI-INTERNAL TERPRI
MOVEI A,NIL
ITERPRI: PUSH P,A ;INTERNAL TERPRI - SAVES A,B,C
MOVEI TT,↑M ;MUST HAVE FILE ARRAY IN AR1,
PUSHJ P,TYO6 ; READTABLE IN AR2A
MOVEI TT,↑J
PUSHJ P,TYO6
JRST POPAJ
] ;END OF IFN QIO
SUBTTL PRINT, PRIN1, PRINC
IFE QIO,[
%PRINT:
PRINT: MOVEI R,TYO ;LIKE (PROG2 (TERPRI) (PRIN1 X) (TYO 40))
PUSHJ P,ITERPRI
CTY1: PUSHJ P,PRIN1
CTY2: %SPC%
POPJ P,
PRINCB: SKIPA A,B
%PRIN1:
PRIN1: SKIPA R,CTYO ;REMEMBER, PUSHJ IS POSITIVE
%PRINC:
PRINC: HRROI R,TYO
PUSHJ P,PRINTY
JRST TRUE
] ;END OF IFE QIO
IFN QIO,[
PRINT: SKIPN AR1,TAPWRT
JRST $PRINT
SKIPA AR1,VOUTFILES
%PRINT: JSP F,PRNARG ;LSUBR (1 . 2)
JFCL Q%PRINT
$PRINT: JSP T,GTRDTB
PUSHJ P,ITERPRI
CTY1: PUSHJ P,$PRIN1
CTY2: %SPC%
POPJ P,
PRIN1: SKIPN AR1,TAPWRT
JRST $PRIN1
SKIPA AR1,VOUTFILES
%PRIN1:
%PR1: JSP F,PRNARG ;LSUBR (1 . 2)
JFCL Q%PR1
$PRIN1: HRRZI R,$TYO
%PR1A: JSP T,GTRDTB
PUSHJ P,PRINTY
JRST TRUE
PRINCB: MOVEI B,(A)
PRINC: SKIPN AR1,TAPWRT
JRST $PRINC
SKIPA AR1,VOUTFILES
%PRINC:
%PRC: JSP F,PRNARG ;LSUBR (1 . 2)
JFCL Q%PRC
$PRINC: HRROI R,$TYO
JRST %PR1A
;;; SUBR VERSIONS - *PRINT, *PRIN1, *PRINC
IRPS X,,[PRT$:PR1$:PRC$:]Y,,[$PRINT,$PRIN1,$PRINC]
X: JSP F,PRNAR$
Q!X
JRST Y
TERMIN
] ;END OF IFN QIO
SUBTTL MAIN PRINTOUT ROUTINE
;;; ***** OKAY, OUTPUT LOVERS, HERE'S YOUR MAIN PRINT ROUTINE *****
;;; CALLED WITH OBJECT TO PRINT IN A, ADDRESS OF "TYO" ROUTINE IN R.
;;; CLOBBERS A (RETURNS GARBAGE); TO SAVE A OVER PRINTY, USE APRINT.
;;; VARIOUS BITS ARE KEPT IN THE LEFT HALF OF R.
;;; SOME ARE PASSED IN, AND OTHERS ARE INITIALIZED AND USED INTERNALLY.
PR.PRC==400000 ;MUST BE SIGN BIT! 0 => PRIN1, 1 => PRINC. (PASSED IN)
PR.ATR==200000 ;1 => DO AUTO-TERPRI HACKS
PR.NUM==4000 ;SYMBOL LOOKS LIKE A NUMBER SO FAR
PR.NVB==2000 ;NOT PROVEN YET THAT VERTICAL BAR NEEDED
PR.EFC==1000 ;EMBEDDED FUNNY CHARACTER IN SYMBOL FLAG (1 => NONE SEEN)
PR.NLS==400 ;NOT PROVEN YET THAT LEADING SLASH NEEDED
;;; PRINTA EXPECTS B,C,T,TT,R SAFE OVER THE "TYO" ROUTINE.
;;; THE "TYO" ROUTINE GENERALLY EXPECTS AR1 AND AR2A SAFE OVER PRINTA.
;;; USES DIRECTLY OR INDIRECTLY A,B,C,T,TT,D,R,F.
;;; IN THE USELESS VERSION OF LISP, THERE ARE ABBREVIATION HACKS:
;;; PRINTY IS THE ENTRY FOR PRIN1/PRINC; ABBREVIATION IS CONTROLLED
;;; BY BIT 1.1 OF (STATUS ABBREVIATE). TYOSW INDICATES WHETHER
;;; A CHAR IS MEANT FOR TTY, FILES, OR BOTH (IN THIS WAY THE TTY
;;; CAN RECEIVE ABBREVIATIONS WHILE FILES RECEIVE FULL S-EXPRS).
;;; PRINTF IS THE ENTRY FOR FLATSIZE/EXPLODE; ABBREVIATION IS
;;; CONTROLLED BY BIT 1.2 OF (STATUS ABBREVIATE).
;;; PRINTA IS THE ENTRY FOR ALL OTHER PRINT HACKERS; IT
;;; NEVER ABBREVIATES.
IFE USELESS,[
PRINTY:
IFE QIO,[
SKIPN TAPWRT ;ENTRY FOR PRIN1/PRINC
SKIPN TTYOFF ;FAST RETURN IF NO DEVICES ENABLED
JRST PRINTA
IFN MOBIOF, SKIPE DISPON
IFN MOBIOF, JRST PRINTA
10% SKIPN LPTON
POPJ P,
] ;END OF IFE QIO
SKIPN V%TERPRI
TLOA R,PR.ATR ;PRIN1/PRINC NORMALLY WANT AUTO-TERPRI HACKS
PRINTF: ;ENTRY FOR FLATSIZE/EXPLODE
PRINTA: TLZ R,PR.ATR ;OTHER GUYS DON'T WANT AUTO-TERPRI HACKS
PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING
ROT A,-SEGLOG ;NOTE THAT A IS SAFE ON PDL
SKIPL TT,ST(A) ;MUST DO A ROT, NOT LSH! SEE PRINX
JRST PRINX
%LPAR% ;PRINT A LIST. FIRST TYO A (
PRINT4: HLRZ A,@(P)
IFN HNKLOG,[
TLNE TT,HNK
JRST PRINH0
] ;END OF IFN HNKLOG
PUSHJ P,PRINT3 ;NOW PRINT CAR OF THE LIST
HRRZ A,@(P)
JUMPE A,PRIN8A ;IF CDR IS NIL, NEED ONLY A )
PRIN7A: MOVEM A,(P)
%SPC% ;ELSE SPACE IN BETWEEN
LSH A,-SEGLOG ;WE KNOW A IS NON-NIL!
SKIPGE TT,ST(A)
JRST PRINT4 ;IF CDR IS NON-ATOMIC, LOOP
%DOT% ;ELSE DOTTED LIST
%SPC%
PUSHJ P,PRIN1A ;SO PRINT THE ATOM AFTER THE LISP DOT
PRIN8A: %RPAR% ;NOW TYO A )
JRST POP1J
] ;END OF IFE USELESS
IFN USELESS,[
PRINTY: MOVEI D,PRINT1 ;ENTRY FOR PRIN1/PRINC
SKIPE V%TERPRI
TLZA R,PR.ATR
TLO R,PR.ATR
JRST PRINT0
PRINTF: MOVEI D,PRINT2 ;ENTRY FOR FLATSIZE/EXPLODE
TLZ R,PR.ATR
JRST PRINT0
APRINT: PUSH P,A
PUSH P,CPOPAJ
PRINTA: MOVEI D,PRIN3A ;ENTRY FOR NO ABBREVIATIONS
TLZ R,PR.ATR
PRINT0: PUSH P,A ;CLOBBERS ARG (RETURNS GARBAGE)
SKIPN V.RSET ;IF IN *RSET MODE, CHECK VALUES OF
JRST PRIN0A ; PRINLEVEL AND PRINLENGTH
IRP X,,[%LEVEL,%LENGTH]Y,,[%LV,%LN]
Y!CHK: SKIPN A,V!X ;NIL IS A VALID VALUE
JRST PRT!Y
SKOTT A,FX
JRST Y!ERR
SKIPGE (A)
JRST Y!ERR
PRT!Y:
TERMIN
PRIN0A: SETOM PRINLV ;PRINLV HAS <ACTUAL PRINT LEVEL>-1
SETZM ABBRSW ;ASSUME ABBRSW ZERO
JSP T,RSXST
MOVEI A,LRCT-2 ;GET (STATUS ABBREVIATE)
NW% HRRZ T,@RSXTB
NW$ LDB T,[001120,,RSXTB] ;PICK UP CHTRAN
HRRZ A,(P) ;MUST LEAVE ARG IN A FOR PRINT3
SETZM PRPRCT
JRST (D) ;DISPATCH TO PRINT1, PRINT2, PRINT3
PRINT1: SETOM ABBRSW ;PRIN1/PRINC
10% Q% SKIPN LPTON ;IF ANY FILES OPEN, MUST DECIDE WHETHER
SKIPE TAPWRT ; OR NOT TO ABBREVIATE THEM
JRST PRIN1Q
IFN MOBIOF, SKIPE DISPON
IFN MOBIOF, JRST PRIN1Q
SKIPN TTYOFF ;IF NO FILES OPEN, THEN ABBREVIATE FOR TTY
JRST PRIN3A
Q% JRST POPAJ ;IF NO OUTPUT AT ALL, JUST GIVE UP!
PRIN1Q: TRNN T,1 ;ULTIMATE DECISION ON FILE ABBREVIATION
HRRZS ABBRSW ; COMES FROM (STATUS ABBREVIATE)
JRST PRIN3A
PRINT2: TRNE T,2 ;FLATSIZE/EXPLODE - DECIDE WHETHER IT
SETOM ABBRSW ; WANTS ABBREVIATION OR NOT
JRST PRIN3A
PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING
PRIN3A: ROT A,-SEGLOG ;NOT LSH! SEE PRINX
SKIPL TT,ST(A)
JRST PRINX ;IF SO, USE AN ATOM PRINTER
MOVE T,TYOSW ;SAVE OLD VALUE OF TYOSW
HRLM T,-1(P) ; (I.E. THAT OF PREVIOUS LEVEL)
JUMPN T,PRINT4 ;IF PREVIOUS LEVEL WAS NON-ABBREV,
SKIPN ABBRSW ; OR IF WE DON'T EVER WANT ABBREV,
JRST PRINT4 ; THEN NEEDN'T TRY TO ABBREV!
AOS T,PRINLV ;ELSE INCREMENT LEVEL COUNT
SKIPE V%LEVEL ;IF PRINLEVEL=NIL, OR IF ACTUAL LEVEL
CAMGE T,@V%LEVEL ; IS LESS, THEN DON'T ABBREV
JRST PRINT4
SKIPL ABBRSW
SETOM TYOSW
CAME T,@V%LEVEL ;IF WE'RE EXACTLY EQUAL TO PRINLEVEL,
JRST PRIN3F
MOVEI T,1
PUSHJ P,PRINLP
%NMBR% ; SHOOT OUT LEVEL ABBREVIATION
PRIN3F: SKIPGE ABBRSW ;IF WE ONLY WANT ABBREVIATION,
JRST PRINT9 ; NEEDN'T GROVEL OVER THE SUBLIST
HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE
PRINT4: PUSH FXP,PRPRCT ;SAVE PARENS COUNTS
HLLOS PRPRCT ;CLEAR RIGHT PARENS COUNT, AND
AOS PRPRCT ; INCREMENT LEFT PARENS COUNT
PUSH FXP,XC-1 ;<ACTUAL PRINT LENGTH>-1 FOR THIS LEVEL
MOVE T,TYOSW ;SAVE CURRENT TYOSW (DETERMINES WHETHER
HRLM T,(P) ; ABBREV MODE OUTPUT WANTS A ) AT END)
PRINT5: SKIPN TYOSW ;IF WE ARE IN NON-ABBREV ONLY MODE,
SKIPN ABBRSW ; OR IF WE NEVER WANT ABBREV,
JRST PRINT7 ; THEN DON'T TRY TO ABBREV!
AOS T,(FXP) ;ELSE INCREMENT PRINT LENGTH
SKIPE V%LENGTH ;IF PRINLENGTH=NIL, OR IF WE'RE LESS
CAMGE T,@V%LENGTH ; THAN IT, THEN DON'T ABBREV
JRST PRINT7
SKIPL ABBRSW
SETOM TYOSW
CAME T,@V%LENGTH
JRST PRINT6 ;IF WE'RE EXACTLY EQUAL, THEN ABBREV
MOVEI T,3
PUSHJ P,PRINLP
REPEAT 3, %DOT%
PRINT6: SKIPGE ABBRSW ;IF WE DON'T WANT NON-ABBREV ONLY MODE,
JRST PRINT8 ; THEN CAN IGNORE REST OF LIST
HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE
PRINT7: HRRZ A,(P)
HRRZ B,(A)
HLRZ A,(A)
HRRZ T,-1(FXP)
ADDI T,1
SKIPN B
HRRM T,PRPRCT
IFN HNKLOG,[
TLNE TT,HNK
JRST PRINH0
] ;END OF IFN HNKLOG
PUSHJ P,PRINT3 ;SO PRINT THE CAR OF THE LIST
SETZM PRPRCT
HRRZ A,(P)
HRRZ A,(A)
JUMPE A,PRINT8 ;IF CDR IS NIL, NEED ONLY A ) NOW
PRIN7A: HRRM A,(P)
%SPC% ;ELSE SPACE BETWEEN
LSH A,-SEGLOG
SKIPGE TT,ST(A)
JRST PRINT5 ;IF CDR NON-ATOMIC, THEN LOOP
%DOT% ;ELSE WE HAVE A DOTTED LIST
%SPC%
HRRZ T,-1(FXP)
ADDI T,1
MOVEM T,PRPRCT
PUSHJ P,PRIN1A ;PRINT THE ATOM AFTER THE LISP DOT
PRINT8: HLRZ T,(P) ;THIS WILL TELL TYO WHAT TO
MOVEM T,TYOSW ; DO WITH THE )
PRIN8A: SUB FXP,R70+1
POP FXP,PRPRCT
%RPAR% ;TYO A ) TO END THE LIST
PRINT9: HLRZ T,-1(P) ;RESTORE TYOSW TO WHAT IT WAS
MOVEM T,TYOSW ; ON LAST (RECURSIVE!) ENTRY
JUMPN T,POP1J ;IF AND ONLY IF WE AOS'ED PRINLV,
SKIPE ABBRSW ; WE MUST NOW SOS IT, AND THEN POP1J
SOS PRINLV
JRST POP1J
] ;END OF IFN USELESS
SUBTTL PRINT A HUNK
IFN HNKLOG,[
PRINH0: PUSH FXP,TT
PUSHJ P,PRINT3 ;PRINT A HUNK SEEN FOR A LIST CELL
IFN USELESS, SETZM PRPRCT
POP FXP,TT
MOVSI T,-2
2DIF [LSH T,(TT)]0,QHUNK1
HRR T,(P)
ADD T,R70+1
PUSH P,T
PRINH1: MOVEM T,(P)
HRRZ A,(P)
HRRZ A,(A)
CAIN A,-1
JRST PRINH3
%SPC%
%DOT%
%SPC%
PUSHJ P,PRINT3
HRRZ A,(P)
HLRZ A,(A)
CAIN A,-1
JRST PRINH3
%SPC%
%DOT%
%SPC%
PUSHJ P,PRINT3
MOVE T,(P)
AOBJN T,PRINH1
PRINH3: SUB P,R70+1
HRRZ A,(P)
HRRZ A,(A)
; JUMPN A,PRIN7A
JUMPN A,PRINH4
IFN USELESS,[
HLRZ T,(P)
MOVEM T,TYOSW
MOVEI T,2
PUSHJ P,PRINLP
] ;END OF IFN USELESS
%SPC%
%DOT%
JRST PRIN8A
PRINH4: MOVEI TT,(A) ;KLUDGE
LSH TT,-SEGLOG
SKIPL ST(TT)
JRST PRIN7A
REPEAT 2, %SPC%
JRST PRIN7A
] ;END OF IFN HNKLOG
SUBTTL PRINT ATOM DISPATCH, AND PRINT AN ARRAY OR A RANDOM
PRINX: PUSH P,CPOP1J ;PRINT AN ATOM (ON THE PDL)
PRIN1A: ;TT HAS ST ENTRY
HRRZ A,-1(P) ;NIL IS SYMBOL, NOT RANDOM!!!
JUMPE A,PRINIL
2DIF JRST (TT),.,QLIST .SEE STDISP ;TT MUST HAVE ST ENTRY
JRST PRINI ;FIXNUM
JRST PRINO ;FLONUM
BG$ JRST PRINB ;BIGNUM
JRST PRINN ;SYMBOL
REPEAT HNKLOG, .VALUE ;HUNKS
JFCL ;RANDOM
IFN USELESS,[
MOVEI T,25.
PUSHJ P,PRINLP
SETZM PRPRCT
] ;END OF IFN USELESS
%NMBR% ;ARRAY (AND RANDOM)
TLNN TT,SA
JRST PRINX5
HRRZ A,-1(P)
MOVE TT,ASAR(A)
CAIE TT,ADEAD
JRST PRINA2
SKIPA TT,[440700,,[ASCIZ \DEAD-ARRAY\]]
PRINA1: PUSHJ P,(R)
ILDB A,TT
JUMPN A,PRINA1
POPJ P,
PRINA2:
Q$ TLNE TT,AS<JOB+FIL>
Q$ JRST PRNFL
JFFO TT,.+1
HRRZ A,ARYTYP(D)
TLC TT,AS<SX> ;CROCK FOR NSTORE ARRAYS
TLNN TT,AS<SX+GCP>
SETZ A,
PUSHJ P,PRINSY
%NEG%
HRRZ A,-1(P)
LDB F,[TTSDIM,,TTSAR(A)]
PRINA3: HRRZ A,-1(P)
MOVNI TT,(F)
MOVE TT,@TTSAR(A)
IFE USELESS, MOVE C,@VBASE ;BETTER BE A FIXNUM!
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
SOJE F,PRINA4
%CLN%
JRST PRINA3
PRINA4: %NEG%
PRINX5: HRRZ TT,-1(P)
PRINL4: MOVEI C,10 ;N BASE 8
JRST PRINI3
IFN QIO,[
SUBTTL PRINT A FILE OBJECT
PRNFL: SKIPA TT,[440700,,[ASCIZ \FILE-\]]
PUSHJ P,(R)
ILDB A,TT
JUMPN A,.-2
HRRZ A,-1(P)
MOVE TT,TTSAR(A)
MOVEI A,Q$IN
TLNE TT,TTS<IO>
MOVEI A,Q$OUT
PUSHJ P,PRINSY
%NEG%
HRRZ B,-1(P)
%VBAR%
MOVEI TT,F.RDEV
SKIPN TT,@TTSAR(B)
JRST PRNF1
PUSHJ P,PRNF6
%CLN%
PRNF1: MOVEI TT,F.RSNM
SKIPN TT,@TTSAR(B)
JRST PRNF2
PUSHJ P,PRNF6
%SEMI%
PRNF2: MOVEI TT,F.RFN1
SKIPN TT,@TTSAR(B)
JRST PRNF3
PUSHJ P,PRNF6
%SPC%
PRNF3: MOVEI TT,F.RFN2
SKIPE TT,@TTSAR(B)
PUSHJ P,PRNF6
IFN JOBQIO,[
MOVEI TT,J.INTB
MOVE T,ASAR(B)
TLNE T,AS<JOB>
SKIPE @TTSAR(B)
JRST PRNF4
%SPC% ;A NUMBER SIGN FOR A FOREIGN JOB
%NMBR%
PRNF4:
] ;END OF IFN JOBQIO
%VBAR%
JRST PRINA4
PRNF6: SETZ T, ;PRINT A SIXBIT FILE NAME
LSHC T,6 ; WITH NECESSARY ↑Q'S
JUMPE T,PRNF6C
CAIE T,':
CAIN T,';
JRST PRNF6C
PRNF6A: MOVEI A,40(T)
PRNF6B: PUSHJ P,(R)
JUMPN TT,PRNF6
POPJ P,
PRNF6C: HRLM T,(P)
%CTLQ%
HLRZ T,(P)
JRST PRNF6A
] ;END OF IFN QIO
SUBTTL PRINT AN ATOMIC SYMBOL
PRINSY: PUSH P,A
PUSH P,CPOP1J
PRINN: SKIPA A,-1(P)
PRINIL: MOVEI A,[$$$NIL,,]
JSP C,MAPNAME
JUMPGE R,PRNN2
IFN USELESS,[
MOVEI TT,(B)
SETZ T,
PRNN0: ADDI T,5
HRRZ TT,(TT)
JUMPN TT,PRNN0
PUSHJ P,PRINLP
] ;END OF IFN USELESS
PRNN1: JSP C,(C) ;FOR PRINC, JUST OUTPUT THE CHARS
POPJ P,
MOVEI A,(TT)
PUSHJ P,(R)
JRST PRNN1
PRNN2: JSP C,(C) ;GET FIRST CHAR
POPJ P, ;DO NOTHING FOR NULL PNAME
TLO R,PR.NVB+PR.NUM+PR.EFC+PR.NLS
SETZ F, ;F COUNTS: <# SLASHES,,# CHARS>
HRRZ A,VREADTABLE
MOVE D,@TTSAR(A)
TLNN D,14 ;IF NOT A DIGIT OR A SIGN,
TLZ R,PR.NUM ; THEN IT ISN'T NUMBER-LIKE
TLNN D,400 ;IF NOT SLASHIFIED AS FIRST CHAR,
AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER
TLZ R,PR.EFC ;ELSE ONE FUNNY CHAR SEEN ALREADY
TLNE D,171000 ;REAL WEIRDIES FORCE VERTICAL BARS
TLZ R,PR.NVB
PRNN3: ADD F,R70+1 ;BUMP CHAR COUNT AND SLASH COUNT
PRNN3A: JSP C,(C) ;GET NEXT CHAR
JRST PRNN4
MOVE D,@TTSAR(A)
TLNN D,24 ;IF IT LOOKS LIKE A NUMBER SO FAR
TLZN R,PR.NUM ; BUT THIS NEXT CHAR ISN'T DIGIT OR ARROW,
JRST PRNN3B
TRNE F,777770 ; THEN WE NEED A LEADING SLASH IF THERE WERE
TLZ R,PR.NLS ; MORE THAN SEVEN LEADING NUMBER-LIKE CHARS
PRNN3B: TLNN D,100 ;IF NOT SLASHIBLE IN FIRST POSITION,
PRNN3C: AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER
TLNN D,2000 ;VERTICAL BARS CAN'T HELP A SLASH
CAIN TT,"| ; OR VERTICAL BAR, SO COUNT THEM AS
AOJA F,PRNN3C ; TWO CHARACTERS AND NO SLASHES
TLNN D,171000 ;REAL WEIRDIES
TLZN R,PR.EFC ; OR TWO EMBEDDED FUNNY CHARS
TLZ R,PR.NVB ; FORCE VERTICAL BARS
JRST PRNN3
PRNN4: CAIN F,1 ;A SIGN WITH NO FOLLOWING
TLNN D,10 ; DIGITS DOESN'T NEED A SLASH
CAIA
JRST PRNN4A
TLNE R,PR.NUM ;IF THE WHOLE THING IS NUMBER-LIKE,
TLZ R,PR.NLS ; THEN DEFINITELY NEED A LEADING SLASH
PRNN4A: MOVEI T,2(F)
TLNN R,PR.NVB
JRST PRNN4B
HLRZ T,F ;WE AREN'T USING VERTICAL BARS
ADDI T,1(F) ; SO MUST COMPUTE UP ROOM TAKEN BY
TLNN R,PR.NLS ; CHARS AND SLASHES, PLUS ONE FOR THE SPACE
ADDI T,1 ; WHICH MAY FOLLOW
PRNN4B: PUSHJ P,PRINLP
SKIPN A,-1(P)
MOVEI A,[$$$NIL,,]
JSP C,MAPNAME
TLNE R,PR.NVB
JRST PRNN6
%VBAR% ;DO THE VERTICAL BAR THING
PRNN5: JSP C,(C)
JRST VBARPOPJ
CAIE TT,↑M
CAIN TT,"|
JRST PRNN5A
MOVE A,VREADTABLE
MOVE D,@TTSAR(A)
TLNE D,2000
PRNN5A: %SLSH%
MOVEI A,(TT)
PUSHJ P,(R)
JRST PRNN5
VBARPOPJ: %VBAR%
POPJ P,
PRNN6: MOVEI F,400
PRNN6A: JSP C,(C)
POPJ P,
MOVE A,VREADTABLE
MOVE D,@TTSAR(A)
TLOE R,PR.NLS
TLNE D,(F)
%SLSH%
MOVEI A,(TT)
PUSHJ P,(R)
MOVEI F,100
JRST PRNN6A
;;; COROUTINE TO DELIVER UP CHARACTERS OF A PRINT NAME.
;;; USES JSP C,(C) TO CALL. USES B, T; YIELDS CHARS IN TT.
;;; SETUP USES A. SKIPS UNLESS NO MORE CHARS.
MAPNAME: HLRZ B,(A)
HRRZ B,1(B)
JSP C,(C)
MAPNM1: HLRZ T,(B)
MOVE T,(T)
MAPNM2: SETZ TT,
ROTC T,7
JUMPE TT,MAPNM3
JSP C,1(C)
JRST MAPNM2
MAPNM3: HRRZ B,(B)
JUMPN B,MAPNM1
JRST (C)
;;; ROUTINE TO FEED FORMATTING INFORMATION TO TYO IF DESIRED,
;;; THEN PRINT ANY PENDING LEFT PARENTHESES.
;;; THE LENGTH OF THE ATOM TO BE PRINTED IS IN T.
;;; USES ONLY A AND T.
PRINLP: TLNN R,PR.ATR
JRST PLP1
IFN USELESS,[
MOVSI T,(T)
ADD T,PRPRCT
HLRZ T,T
ADD T,PRPRCT
] ;END OF IFN USELESS
TRNE T,777000
MOVEI T,777
HRROI A,1(T) ;ALLOW FOR FOLLOWING SPACE
PUSHJ P,(R)
PLP1:
IFE USELESS, POPJ P,
IFN USELESS,[
HLRZ T,PRPRCT
PRINLQ: SOJL T,CPOPJ
%LPAR%
JRST PRINLQ
] ;END OF IFN USELESS
SUBTTL PRINT A FIXNUM
PRINI: MOVE A,VBASE
IFN USELESS, CAIN A,QROMAN
IFN USELESS, JRST PRINRM
SKOTT A,FX
JRST BASER
MOVE C,(A) ;TRUE VALUE OF BASE IN C
CAIG C,36.
CAIGE C,2
JRST BASER
PRI2D: HRRZ A,-1(P)
JSP T,FXNV1 ;THE TYO ROUTINE MUST SAVE TT HERE
IFN USELESS,[
MOVMS TT ;ESTIMATE LENGTH OF FIXNUM
JFFO TT,.+2 ; ASSUMING OCTAL BASE
MOVEI D,43
MOVNI T,3
IDIVM D,T ;AVOID CLOBBERING EXTRA ACS
ADDI T,14
SKIPGE @-1(P) ;ALLOW FOR MINUS SIGN
ADDI T,1
PUSHJ P,PRINLP
MOVE TT,@-1(P)
] ;END OF IFN USELESS
CAIN C,8
JRST PRI2B
PRI2C: JUMPL TT,PRI2Q
SKIPE V.NOPOINT
JRST PRINI2 ;HAPPY PRATT?
CAILE C,10.
%POS%
JRST PRINI2
PRI2Q: %NEG%
PRI2A: MOVNS TT
PRINI2: JSP T,PRI. ;INSERT DECIMAL POINT IF NECESSARY
PRINI9: MOVEI TT-1,1 ;MUST SAVE F - SEE GCPNT1, GCWORRY
TLZN TT,400000 ;IF NUMBER COULD BE MOBY, THEN MOVE HIGH ORDER BIT
PRINI3: SETZ T,
JSP D,PRINI5
SKIPE TT,T
PUSHJ P,PRINI3
FP7A1: HLRZ A,(P)
FP7B: MOVEI A,"0(A)
CAIE A,".
JRST (R)
%DCML%
POPJ P,
PRINI5: DIVI TT-1,(C)
CAILE TT,9
ADDI TT,"A-"9-1 ;KLUDGY DIGITS GREATER THAN 9 ARE "A,B,C,D,. . .,Y,Z"
PRINI7: HRLM TT,(P)
JRST (D)
PRI.: CAIN C,10.
SKIPE V.NOPOINT
JRST (T)
HRLI T,".-"0
HLLM T,(P)
PUSH P,[FP7A1]
JRST (T)
PRI2B: MOVM D,TT
TRNN D,777
TLNN D,-1
JRST PRI2C
MOVEI T,(C)
MOVE C,VREADTABLE
MOVE D,TT
MOVEI TT,LRCT-1 ;RH OF LAST RCT ENTRY IS (STATUS ←)
HRRZ C,@TTSAR(C)
EXCH T,C
MOVE TT,D
JUMPE T,PRI2C
MOVNI D,11 ;PRINT OUT AS ONE OF:
TRNE TT,777000 ; NNNNNNNNN←11
JRST PRI2B3 ; NNNNNN←22
MOVNI D,22 ; NNN←33
TLNN TT,777 ; N←41
MOVNI D,33 ; IN ORDER THAT LOSERS NEED NOT
TLNN TT,77777 ; COUNT ALL THE ZEROS OF AN
MOVNI D,41 ; OCTAL NUMBER.
PRI2B3: ASH TT,(D)
PUSH FXP,D
PUSHJ P,PRI2C
%BAK%
POP FXP,TT
JRST PRI2A
IFN USELESS,[
PROMAN: AOS (P)
JRST PRINR0
PRINRM: HRRZ A,-1(P)
JSP T,FXNV1
PRINR0: MOVEI C,10.
JUMPLE TT,PRI2D
CAIL TT,4000.
JRST PRI2D
MOVEI T,15.
PUSHJ P,PRINLP
SETZ T,
PRINR1: IDIVI TT,10.
HRLM D,(P)
ADDI T,1
JUMPE TT,PRINR2
PUSHJ P,PRINR1
PRINR2: HLRZ TT,(P)
SUBI T,1
JUMPE TT,CPOPJ
CAIE TT,9
JRST PRINR3
HLRZ A,PRINR9(T)
PUSHJ P,(R)
HLRZ A,PRINR9+1(T)
JRST (R)
PRINR3: CAIE TT,4
JRST PRINR4
HLRZ A,PRINR9(T)
PUSHJ P,(R)
HRRZ A,PRINR9(T)
JRST (R)
PRINR4: CAIGE TT,5
JRST PRINR6
SUBI TT,5
HRRZ A,PRINR9(T)
PRINR5: PUSHJ P,(R)
PRINR6: SOJL TT,CPOPJ
HLRZ A,PRINR9(T)
JRST PRINR5
PRINR9: "I,,"V
"X,,"L
"C,,"D
"M,,
] ;END OF IFN USELESS
SUBTTL PRINT A FLONUM
PRINO:
IFN USELESS,[
MOVEI T,15. ;GROSS ESTIMATE OF LENGTH OF FLONUM
PUSHJ P,PRINLP
] ;END OF IFN USELESS
HRRZ C,-1(P) ;FLOATING POINT NUMBER
MOVE T,(C)
JUMPGE T,FP1
%NEG%
MOVN T,(C)
FP1: SETZB TT,C ;AT FP3, TT WILL HOLD POSSIBLY ADDITIONAL
MOVEI F,0
CAMGE T,[.01] ;SIGNIFICANT BINARY DIGITS OF NUMBER
SOJA C,FP4 ;AT THIS TIME, C IS INDICATOR TO FP4
CAML T,[1.0↑8] ;C=-1 => NEGATIVE EXPONENT [X < 1.0E-2]
AOJA C,FP4E0 ;C=+1 => POSITIVE EXPONENT [X > 1.0E+8 - 1]
CAMGE T,[1.0]
JRST FP3B
PUSHJ P,FPL10 ;<# OF DIGITS TO LEFT OF .>+1 WILL NOW BE IN F
SUBI F,9
FP3: SETZB TT,D
ASHC T,-27. ;SPLIT EXPONENT PART OFF
ASHC TT,-243(T) ;SPLIT NUMBER INTO INTEGRAL AND FRACTIONAL PART
MOVNS F ;F NOW HOLDS # OF DIGITS TO PRINT TO RIGHT OF .
PUSH FXP,F
MOVSI F,200000 ;COMPUTE POSITION OF LAST SIGNIFICANT BITS
ASH F,-243+1+<43-27.>(T)
PUSH FXP,F
FP1A: MOVEM TT+1,FPTEM
MOVEI C,10.
PUSHJ P,PRINI3 ;MUSN'T DISTURB B
%DCML%
POP FXP,TT
EXCH TT,FPTEM
POP FXP,C
FP3A: MOVE T,TT
MULI T,12
MOVE F,FPTEM
IMULI F,10.
CAMGE TT,F
JRST FPX0
MOVN D,F
TLZ D,400000
CAMLE TT,D
AOJA T,FPX0 ;LAST SIG DIGIT, BUT ROUND UPWARDS
CAIN C,2 ;ON NINTH OUTPUT DIGIT, USE ONLY HALF A DIGIT
ASH F,-1 ;FOR END-OF-PRECISION TEST
MOVEM F,FPTEM
PUSHJ P,FPX0
SOJG C,FP3A
POPJ P, ;LAST SIGNIFICANT DIGIT, SO STOP
FPX0: MOVEI A,"0(T)
JRST (R)
FP3B: MOVNI F,10.
CAML T,[.1] ;.1 .LE. X < 1.0
JRST FP3
SOJA F,FP3 ;.01 .LE. X < .1
FP4: JUMPN T,FP4E ;FLOATING POINT "E" FORMAT
PUSHJ P,FP4A ;CLEVER WAY TO PRINT OUT 0.0 QUICKLY
%DCML%
FP4A: MOVEI A,"0
JRST (R)
FP4E0: FDVL T,[1.0↑8]
FDVR T+1,[1.0↑8]
FADL T,T+1
ADDI F,8
CAML T,[1.0↑8]
JRST FP4E0
FP4E1: CAMGE T,FP10.0
JRST FP4B
FDVL T,FP10.0
FDVRI T+1,(10.0)
FADL T,T+1
AOJA F,FP4E1
FP4E: CAML T,[1.0↑-8]
JRST FP4E2A
FMPR T+1,[1.0↑8]
MOVEM T+1,T+2
FMPL T,[1.0↑8]
UFA T+1,T+2
FADL T,T+2
ADDI F,8
JRST FP4E
FP4E2: FMPRI T+1,(10.0)
MOVEM T+1,T+2
FMPL T,FP10.0
UFA T+1,T+2
FADL T,T+2
FP4E2A: CAMGE T,FP1.0
AOJA F,FP4E2
;FALLS THROUGH
;FALLS IN
FP4B: FADR T,TT
CAMGE T,FP10.0 ;ROUNDING-UP MAY TAKE US OUT OF RANGE AGAIN
JRST .+3
FDVRI T,(10.0)
ADD F,C
PUSH P,F ;F HAS "E" TYPE EXPONENT
ADDI C,FP4B0
PUSH P,C ;"+" OR "-" FOR OUTPUT
SETZ TT,
MOVNI F,8
PUSHJ P,FP3 ;NUMBER HAS BEEN NORMALIZED FOR 1.0 .LE. X < 10.0
%E%
POPJ P, ;GO TO FB4B0-1 OR FP4B0+1
%NEG%
FP4B0: JRST FP4B3
%POS%
FP4B3: POP P,TT ;EXPONENT VALUE
MOVEI C,10.
JRST PRINI3
FPL10: MOVEI F,8
CAMGE T,FP1.0-1(F)
SOJG F,.-1
POPJ P,
FP1.0: REPEAT 8,1.0↑.RPCNT
FP10.0=FP1.0+1
IFN BIGNUM,[
SUBTTL PRINT A BIGNUM
PRINB:
IFN USELESS,[
HRRZ B,@-1(P)
MOVEI T,1
PRINB0: ADDI T,12.
HRRZ B,(B)
JUMPN B,PRINB0
PUSHJ P,PRINLP
] ;END OF IFN USELESS
HRRZ A,-1(P)
SKIPGE A,(A)
JRST PRINBQ
IFE USELESS, HRRZ D,@VBASE
IFN USELESS,[
HRRZ D,VBASE
CAIE D,QROMAN
SKIPA D,(D)
MOVEI D,10.
] ;END OF IFN USELESS
CAILE D,10.
%POS%
JRST PRINBZ
PRINBQ: %NEG% ;NEGATIVE BIGNUM
PRINBZ: MOVEM R,RSAVE
HRRZM P,FSAVE ;STORE PDL POSITION SO AR1 AND AR2A CAN BE FOUND
PUSH P,AR1
PUSH P,AR2A
PUSHJ P,YPOCB
PUSH P,A
PUSH P,[PRINB4]
MOVE B,VBASE
IFN USELESS,[
CAIN B,QROMAN
SKIPA D,[10.]
] ;END OF IFN USELESS
JSP T,FXNV2
MOVE C,D
JSP T,PRI.
MOVE R,D
MOVEI F,1
MOVE T,D
PRBAB: MUL T,D
JUMPN T,.+4
MOVE T,TT
MOVE R,TT
AOJA F,PRBAB
MOVEM F,NORMF
MOVE D,R
PRINB3: MOVE C,A
HLRZ B,(C)
MOVE F,(B)
MOVEI R,0
PNFBLP: DIV R,D
MOVEM R,(B)
MOVE B,(C)
TRNN B,-1
JRST PRBFIN
MOVE C,(C)
MOVE R,F
HLRZ B,(C)
MOVE F,(B)
JRST PNFBLP
PRBFNA: HLR A,B
PRBFIN: MOVS B,(A)
TLNE B,-1
SKIPE (B)
JRST .+2
JRST PRBFNA
PUSH FXP,F
MOVE R,(A)
TRNN R,-1
JRST PRBNUF
PUSHJ P,PRINB3
PRINBI: POP FXP,TT
MOVE F,NORMF
MOVE R,RSAVE
PRINBJ: SETZ T,
JSP D,PRINI5
SOJE F,FP7A1
MOVE TT,T
PUSHJ P,PRINBJ
JRST FP7A1
PRBNUF: HLRZ A,R
MOVE TT,(A)
MOVE AR2A,FSAVE
MOVE AR1,1(AR2A) ;RESTORE AR1 AND AR2A
MOVE AR2A,2(AR2A)
HRRZ C,VBASE
IFN USELESS, CAIN C,QROMAN
IFN USELESS, SKIPA R,[10.]
JSP T,FXNV3
MOVE C,R
MOVE R,RSAVE
SKIPE TT
PUSHJ P,PRINI3
JRST PRINBI
PRINB4: POP P,A
MOVEI B,TRUTH
PUSHJ P,RECLAIM
POP P,AR2A
POP P,AR1
POPJ P,
] ;END OF IFN BIGNUM
SUBTTL FLATSIZE, FLATC, EXPLODEC, EXPLODEN, EXPLODE
FLATSIZE: PUSH P,CFIX1 ;SUBR 1
SKIPA R,CFLAT2 ;POPJ IS POSITIVE
FLAT4: HRROI R,FLAT2
FLAT3: SETZM FLAT1
PUSHJ P,PRINTF
SKIPA TT,FLAT1
FLAT2: AOS FLAT1
CFLAT2: POPJ P,FLAT2
FLATC: PUSH P,CFIX1 ;SUBR 1
JSP T,SPATOM
JRST FLAT4
JUMPN A,FLATC1
MOVEI TT,3 ;FLATC OF NIL IS 3
POPJ P,
FLATC1: HLRZ TT,(A) ;FAST-FLATC FOR SYMBOLS
HRRZ A,1(TT)
SETZ TT,
FLATC2: HRRZ B,(A) ;COUNT 5 CHARS PER PNAME WORD
ADDI TT,BYTSWD
JUMPE B,FLATC3
HRRZ A,(B)
ADDI TT,BYTSWD
JUMPN A,FLATC2
MOVEI A,(B)
FLATC3: HLRZ A,(A) ;LAST PNAME WORD MAY BE PARTIAL
SKIPN T,(A) ;WATCH OUT FOR NULL PNAME!
SUBI TT,1
TRNE T,177←1
POPJ P,
TRNE T,177←10
SOJA TT,CPOPJ
SUBI TT,3
TDNE T,[177←17]
AOJA TT,CPOPJ
TLNN T,(177←26)
SUBI TT,1
POPJ P,
$EXPLODEC: SKIPA R,EXPLODE ;SUBR 1 ;HRRZI IS NEGATIVE!!!
$$EXPLODEN: HRROI R,EXPL2 ;SUBR 1
SKOTT A,SY
JRST EXPL4
HLRZ T,(A)
HRRZ A,1(T)
PUSH P,R70 ;FORMING LIST OF CHARS
MOVEI B,(P)
PUSH P,A
PUSH P,B
XOR R,EXPLODE
PUSH FXP,R
EXPLY1: SKIPN A,-1(P)
JRST EXPLY9
HLRZ B,(A)
MOVE D,(B)
HRRZ A,(A)
MOVEM A,-1(P)
EXPLY2: JUMPE D,EXPLY1
SETZ TT,
LSHC TT,7
SKIPE (FXP)
JRST EXPLY3
PUSH FXP,D
PUSHJ P,RDCH2
POP FXP,D
JRST EXPLY4
EXPLY3: MOVEI A,IN0(TT) .SEE HINUM
EXPLY4: PUSHJ P,NCONS
HRRM A,@(P)
HRRZM A,(P)
JRST EXPLY2
EXPLY9: SUB P,R70+2
SUB FXP,R70+1
JRST POPAJ
EXPLODE: HRRZI R,EXPL1 ;SUBR 1
EXPL4: PUSH P,R70
HRRZM P,EXPL5
PUSHJ P,PRINTF
JRST POPAJ
EXPL1: SAVE B C
SAVEFX TT R
ANDI A,177
PUSHJ P,RDCH3
POP P,C
EXPL3: PUSHJ P,NCONS
HRRM A,@EXPL5
HRRZM A,EXPL5
EXPL6: RSTRFX R TT
JRST POPBJ
EXPL2: PUSH P,B
SAVEFX TT R
MOVEI A,IN0(A)
JRST EXPL3
SUBTTL BAKTRACE
BAKTRACE:
JSP TT,LWNACK
LA01,,QBAKTRACE
MOVNI TT,1
JRST BKTR0
BAKLIST:
JSP TT,LWNACK
LA01,,QBAKLIST
MOVSI TT,400000
BKTR0: MOVEM TT,BACTYF
MOVEI A,NIL
JUMPE T,.+2
POP P,A
JSP R,GTPDLP
0
JFCL
MOVEI A,(D)
MOVE B,(A)
CAME B,[QBAKTRACE,,CPOPJ]
CAMN B,[QBAKLIST,,CPOPJ]
SOS A ;DONT WANT TO SEE "BAKTRACE←"
MOVEI R,60
HRRZ TT,C2
SUBM A,TT
CAIG TT,(R)
MOVE R,TT
MOVE T,A ;LOOK AT 60 OR SO TOP PDL POSITIONS
SETZM CPJSW
MOVEI B,CPOPJ
BKTR3: MOVE TT,(T) ;CUT OUT STUFF FROM *RSET LOOP, IF USED
CAIN B,(TT)
TLNN TT,-1
JRST .+2
SETOM CPJSW ;APPARENTLY *RSET HAS BEEN ON
TLZ TT,-1#10000
CAMN TT,[10000,,LSPRET]
MOVEI A,-1(T)
SOS T
SOJG R,BKTR3
MOVEM A,BKTRP ;SET UP FOR BAKTRACE LOOP AND GO THERE
MOVE A,BACTYF
AOJE A,BKTR2
PUSH P,R70 ;SET UP LIST TO HOLD BAKLISTING
HRLM P,(P) ;SET UP LAST-OF-LIST POINTER
BKTR2: HRRZ A,C2 ;THE PDL-HUNTING LOOP
ADDI A,1
CAML A,BKTRP
JRST BKTR2X ;EXIT WHEN BACKED UP TO BOTTOM OF PDL
AOSN BACTYF
STRT [SIXBIT \↑MBAKTRACE↑M!\]
HRRZ A,@BKTRP
CAIN A,CPOPJ ;IN *RSET MODE, THIS IS A TAG
JRST BKTR1C ;PUT ON PDL UPON ENTRY TO A FUNCTION
CAIN A,ILIST3
JRST BKTR1B
MOVE D,@BKTRP
TLNE D,10000#-1 ;TO BE PUSHJ RET ADDR, MUST HAVE PC FLAGS IN LH
CAIN A,BKCOM1
JRST BKTR1
CAIL A,BEGFUN
CAIL A,ENDFUN
JRST BKTR1A
CAIE A,CON2
CAIN A,CON3
JRST BKTR1G
CAIN A,PG0A
JRST BKTR1E
CAIN A,LMBLP1
JRST BKTR1
CAILE A,BRLP1
CAILE A,BRLP2
JRST .+2
JRST BKTR1H
Q% CAIN A,RDIN3B
Q% JRST BKTRR5
Q% CAIE A,RDIN3A
CAIN A,REKRD1
JRST BKTRR3
CAIE A,UNBIND
JRST BKTR1A
BKTR1: SOS BKTRP
JRST BKTR2
BKTR2X: AOSE BACTYF
SKIPL BACTYF
JRST TERPRI
POP P,A
JRST RHAPJ
BKTR1A: CAMGE A,@VBPORG ;LETS HOPE THAT BPORG ISN'T SCREWED UP
CAIGE A,BBPSSG
JRST BKTR1
BK1A2: MOVEI AR1,-1(A)
BK1A4: HLRZ B,-1(A) ;SOMEWHERE IN BINARY PROGRAMS
HRRI R,PRINCB ;IF "CALL", THEN SUBR ATOM NAME WILL BE IN B
TRC B,37
TRCE B,37
CAIGE B,(CALL )
JRST BKTR1
CAIG B,(JCALLF 17,)
JRST BK1A1
CAIE B,(XCT) ;MIGHT BE A XCT OF A CALL
JRST .+3 ;JRST OR PUSHJ TO SUBR
HRRZ A,-1(A) ;IF SO, CYCLE THROUGH TO TRY TO
AOJA A,BK1A4 ; FIND CALLED SUBR NAME
MOVEI R,ERRADR ;NOW WE HAVE ONLY BEGINNING ADDRESS OF SUBR
CAIN B,(JRST 0,) ;SO HAS TO BE DECODED INTO ATOM NAME.
JRST BK1A1
CAIE B,(PUSHJ P,)
JRST BKTR1
HLLZ B,@BKTRP
TLNN B,10000 ;USER MODE FLAG - STOPS RANDOM
JRST BKTR1 ; DATA NOT ENTERED BY PUSHJ
BK1A1: MOVE B,-1(A)
TLNE B,7777760 ;CAN'T CHANCE DOING AN INDIRECTION IF
TLNE B,((17)) ; THE UUO IS INDEXED, OR ADDRESSES AN AC
JRST BK1A1B
MOVEI B,@-1(A) ;LET INDIRECT DO ITS THING
BK1A1C: PUSH P,AR1 ;ORIGINAL PC WHEREFROM SUBR WAS CALLED
SKIPGE BACTYF
JRST BK1A3
PUSHJ P,(R)
STRT [SIXBIT \←!\]
POP P,B
PUSHJ P,ERRADR
STRT [SIXBIT \ !\]
JRST BKTR1
BK1A3: CAIE R,ERRADR
SKIPA A,B
PUSHJ P,ERRDCD
EXCH A,(P)
PUSHJ P,ERRDCD
PUSH P,[QLA]
PUSH P,A
MOVNI T,3
JRST BKT1F2
BK1A1B: CAIN R,ERRADR
TDZA B,B
MOVEI B,QM
JRST BK1A1C
BKTR1B: MOVE D,BKTRP
HRRZ B,-1(D) ;PROBABLY FOR ENTRY TO SOME SUBR, LSUBR, OR EXPR
CAIE B,ELSB1 ;LISTING TINGS UP ON THE PDL
CAIN B,ESB1
JRST .+3
CAIE B,IAPPLY
JRST BKTR1
HLRE B,-1(D)
ADDI B,-3(D)
HLRZ A,(B)
JUMPE A,BKTR1
HRRZM B,BKTRP
SKIPGE BACTYF
JRST BKT1B1
STRT [SIXBIT \(!\]
PUSHJ P,PRINC
STRT [SIXBIT \ EVALARGS) !\]
JRST BKTR1
BKTR1C: HLRZ A,@BKTRP ;PROBABLY ENTERED AN F-TYPE FUNCTION
JUMPE A,BKTR1 ;WELL, NIL ISN'T REALLY A FUNCTION
BKTR1F: SKIPGE BACTYF
JRST BKT1F1
PUSHJ P,PRINC
STRT [SIXBIT \← !\]
JRST BKTR1
BKT1B1: SKIPA B,[QEVALARGS]
BKT1F1: MOVEI B,QLA
PUSH P,A
PUSH P,B
MOVNI T,2
BKT1F2: JSP R,LIST1
PUSHJ P,NCONS
HLRZ B,(P)
HRRM A,(B) ;NCONC MOST RECENT GOODIE ONTO END OF LIST
HRLM A,(P) ;UPDATE LAST-OF-LIST POINTER
JRST BKTR1
BKTR1H: MOVNI T,LERSTP+5-1 ;2 FROM BREAK, 2 FROM EDERRL, 1 FROM BRLP = 5
MOVEI A,QBREAK ;-1 SINCE BKTR1 WILL TAKE OFF ONE MORE
JRST BKTR1D
BKTR1E: MOVNI T,LPRP ;BACK UP OFF A PROG
MOVEI A,QPROG
BKTR1D: ADDM T,BKTRP
JRST BKTR1I
BKTR1G: MOVEI A,QCOND ;FOUND A COND ENTRY
BKTR1I: SKIPE CPJSW
JRST BKTR1 ;IF *RSET WAS ON, THEN ENTRY WILL BE MARKED BY CPOPJ
JRST BKTR1F
BKTRR3: SKIPA T,XC-3
BKTRR5: MOVNI T,5
ADDM T,BKTRP
JRST BKTR1
PGTOP PRT,[PRINT,TYO,EXPLODE,FLATC,,BAKTRACE,ETC]
;;@ END OF PRINT 113
;;@ ULAP 80 UTAPE, LAP, AND AGGLOMERATED SUBRS
PGBOT [UIO]
IFN QIO,[
SUBTTL OLD I/O FUNCTIONS IN TERMS OF NEW I/O PRIMITIVES
;;; (DEFUN UREAD FEXPR (FILENAME)
;;; (UCLOSE)
;;; ((LAMBDA (FILE)
;;; (EOFFN UREAD
;;; (FUNCTION
;;; (LAMBDA (EOFFILE EOFVAL)
;;; (UCLOSE)
;;; EOFVAL)))
;;; (INPUSH (SETQ UREAD FILE))
;;; (CAR (DEFAULTF FILE)))
;;; (OPEN (*UGREAT FILENAME) 'IN)))
UREAD: PUSH P,A ;FEXPR
PUSHJ P,UCLOSE
POP P,A
PUSHJ P,UGREAT
PUSH P,[UREAD2]
PUSH P,A
JRST $OPEN
UREAD2: MOVEM A,VUREAD
PUSH P,[UREAD1]
PUSH P,A
PUSH P,[QUREOF]
MOVNI T,2
JRST EOFFN
UREAD1: HRRZ A,VUREAD
PUSHJ P,INPUSH
PUSHJ P,DEFAULTF
JRST $CAR
UREOF: PUSH P,B ;+INTERNAL-UREAD-EOFFN - SUBR 2
PUSHJ P,UCLOSE
JRST POPAJ
;;; (DEFUN UCLOSE FEXPR (X)
;;; (COND (UREAD
;;; ((LAMBDA (OUREAD)
;;; (AND (EQ OUREAD INFILE) (INPUSH -1))
;;; (SETQ UREAD NIL)
;;; (CLOSE OUREAD))
;;; UREAD))
;;; (T NIL)))
UCLOSE: SKIPN A,VUREAD ;FEXPR
POPJ P,
CAMN A,VINFILE
PUSHJ P,INPOP ;SAVES A
SETZM VUREAD
JRST $CLOSE
;;; (DEFUN UWRITE FEXPR (DEVDIR)
;;; (OR DEVDIR (SETQ DEVDIR (CAR (DEFAULTF NIL))))
;;; (*UWRITE (CONS DEVDIR
;;; (COND ((STATUS FEATURE DEC10)
;;; (CONS (STATUS JNAME) '(OUT)))
;;; ((STATUS FEATURE ITS)
;;; '(.LISP. OUTPUT))))
;;; 'OUT
;;; (LIST DEVDIR)))
;;;
;;; (DEFUN UAPPEND FEXPR (FILENAME)
;;; (PROG2 (SETQ FILENAME (*UGREAT FILENAME))
;;; (*UWRITE FILENAME 'APPEND FILENAME)
;;; (RENAME UWRITE
;;; (COND ((STATUS FEATURE DEC10)
;;; (CONS (STATUS JNAME) '(OUT)))
;;; ((STATUS FEATURE ITS)
;;; '(/.LISP/. APPEND))))))
;;;
;;; (DEFUN *UWRITE (NAME MODE NEWDEFAULT) ;INTERNAL ROUTINE
;;; (COND (UWRITE
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (CLOSE UWRITE)
;;; (SETQ UWRITE NIL)))
;;; ((LAMBDA (FILE)
;;; (SETQ OUTFILES
;;; (CONS (SETQ UWRITE FILE)
;;; OUTFILES))
;;; (CAR (DEFAULTF NEWDEFAULT)))
;;; (OPEN NAME MODE)))
UAPPEND: PUSHJ P,UGREAT ;FEXPR
MOVEI C,(A)
MOVEI B,QAPPEND
PUSHJ P,UWRT1
PUSH P,A
HRRZ A,VUWRITE
MOVEI B,QLSPAPP
PUSHJ P,$RENAME
JRST POPAJ
UWRITE: JUMPN A,UWRT0 ;FEXPR
PUSHJ P,DEFAULTF
HLRZ A,(A)
UWRT0: PUSHJ P,NCONS
MOVEI C,(A)
HLRZ A,(C)
MOVEI B,QLSPOUT
PUSHJ P,CONS
MOVEI B,Q$OUT
UWRT1: PUSH P,C ;*UWRITE BEGINS HERE
PUSH P,[UWRT2]
PUSH P,A
PUSH P,B
SKIPE VUWRITE
PUSHJ P,UFILE5
MOVNI T,2
JRST $OPEN
UWRT2: MOVEM A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,CONS
MOVEM A,VOUTFILES
POP P,A
PUSHJ P,DEFAULTF
JRST $CAR
;;; IFN QIO
;;; (DEFUN UFILE FEXPR (SHORTNAME)
;;; (COND ((NULL UWRITE)
;;; (ERROR 'NO/ UWRITE/ FILE
;;; (CONS 'UFILE SHORTNAME)
;;; 'IO-LOSSAGE))
;;; (T (PROG2 NIL
;;; (CAR (DEFAULTF (RENAME UWRITE
;;; (*UGREAT SHORTNAME))))
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (CLOSE UWRITE)
;;; (SETQ UWRITE NIL)
;;; (OR OUTFILES (SETQ ↑R NIL))))))
UFILE0: MOVEI B,QUFILE
PUSHJ P,XCONS
IOL [NO UWRITE FILE!]
UFILE: SKIPN VUWRITE ;FEXPR
JRST UFILE0
PUSHJ P,UGREAT
MOVEI B,(A)
HRRZ A,VUWRITE
PUSHJ P,$RENAME
PUSHJ P,DEFAULTF
PUSH P,A
PUSHJ P,UFILE5
POP P,A
JRST $CAR
UFILE5: HRRZ A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,.DELQ
MOVEM A,VOUTFILES
HRRZ A,VUWRITE
PUSHJ P,$CLOSE
SETZM VUWRITE
SKIPN VOUTFILES
SETZM TAPWRT
POPJ P,
;;; (DEFUN CRUNIT FEXPR (DEVDIR)
;;; (CAR (DEFAULTF (AND DEVDIR (LIST DEVDIR)))))
SCRUNIT: SETZ A,
CRUNIT: SKIPE A ;FEXPR
PUSHJ P,NCONS
PUSHJ P,DEFAULTF
JRST $CAR
;;; IFN QIO
;;; (DEFUN *UGREAT (NAME) ;INTERNAL ROUTINE
;;; (MERGEF (MERGEF NAME
;;; (COND ((STATUS DEC10)
;;; '(* . LSP))
;;; (T '(* . >))))
;;; NIL))
UGREAT: PUSH P,[6BTNML]
UGRT1: PUSHJ P,FIL6BT
REPEAT 3, PUSH FXP,[SIXBIT \*\]
10% PUSH FXP,[SIXBIT \>\]
10$ PUSH FXP,[SIXBIT \LSP\]
PUSHJ P,IMRGF
JRST DMRGF
;;; (DEFUN UPROBE FEXPR (FILENAME)
;;; (SETQ FILENAME (MERGEF (*UGREAT FILENAME) NIL))
;;; (PROBEF FILENAME))
UPROBE: PUSHJ P,UGRT1 ;FEXPR
JRST PROBF0
;;; (DEFUN UKILL FEXPR (FILENAME)
;;; (DEFAULTF (DELETEF FILENAME))))
UKILL: PUSHJ P,$DELETEF
JRST DEFAULTF
] ;END OF IFN QIO
IFE QIO,[
SUBTTL OLD I/O FUNCTIONS IN TERMS OF OLD I/O PRIMITIVES
CRUNIT: JUMPN A,UINIT0 ;GET (MAYBE AFTER SETTING) CRUNIT
SCRUNIT: MOVE A,IUNIT ;GET CRUNIT
JRST UINIT1
UINIT0: HLRZ C,(A) ;CAR IS DEVICE
HRRZ A,(A) ;CADR IS DIRECTORY
SKIPN A
HRRZ A,@IUNIT ;IF NOT GIVEN, USE PRESENT ONE
HLRZ A,(A)
PUSHJ P,NCONS ;MAKE UP NEW CRUNIT
MOVE B,C
PUSHJ P,XCONS
UINIT1: MOVEM A,IUNIT ;SAVE NEW CRUNIT
HLRZ A,@IUNIT
PUSHJ P,SIXMAK ;GET SIXBIT FOR DEVICE
10% HLRM TT,UTIN
10$ MOVEM TT,UTIN
HRRZ A,@IUNIT
HLRZ A,(A)
IFN ITS,[
PUSHJ P,SIXMAK ;GET SIXBIT FOR DIRECTORY
CAME TT,USN
.SUSET [.SSNAM,,TT]
] ;END OF IFN ITS
IFN D10,[
IFE SAIL,[
JSP T,SPATOM
JRST .+3
PUSHJ P,SIXMAK ;SIXBIT PPN
JRST UINIT2
HLRZ B,(A)
JSP T,FXNV2 ;PROJ # IN D
HRRZ A,(A)
HLRZ A,(A)
JSP T,FXNV1 ;PROG # IN TT
HRLI TT,(D)
UINIT2:
] ;END OF IFE SAIL
IFN SAIL,[
HLRZ B,(A) ;PROJ# IN B
HRRZ A,(A)
HLRZ A,(A) ;PROG# IN A
PUSH P,B ;LH PART ON PDL
PUSHJ P,SIXMAK ;GET SIXBIT FOR RH PART
PUSHJ P,SARGT ;RIGHT JUSTIFY BOX
PUSH FXP,TT ;ON ANOTHER STACK
POP P,A ;LH IN A
PUSHJ P,SIXMAK ;GET SIXBIT FOR LH
PUSHJ P,SARGT ;R.J.
POP FXP,D
HLR TT,D ;INSTALL RH PART
] ;END OF IFN SAIL
] ;END OF IFN D10
MOVEM TT,USN
MOVE A,IUNIT
POPJ P,
IFN SAIL,[
SARGT: TLNE TT,77 ;IS RIGHTMOST CHAR ZERO?
POPJ P, ;WIN
LSH TT,-6 ;SLYDE RIGHT
JRST SARGT ;ONE MORE TIME, NOW.
] ;END OF IFN SAIL
IFE D10,[
UGREAT: AOJN T,CPOPJ ;HACK FOR UREAD AND UFILE
HLRZ A,(A) ; TO DEFAULT SECOND FILE NAME TO >
MOVEI B,QGRTL
JRST CONS
] ;END OF IFE D10
;;; IFE QIO
SUBTTL OLD I/O UFILE
UFILE: JSP TT,FWNACK
10% FA01234,,QUFILE
10$ FA0234,,QUFILE
SKIPN UTOOPD
JRST UFILE0
10% PUSHJ P,UGREAT
PUSHJ P,UFNAME
UFILE1: LOCKI
SETZM TAPWRT
IFN ITS,[
MOVEM T,UTIN+3
MOVEM TT,UTIN+4
MOVE T,UWRT
MOVEM T,UTIN
SETZM UTIN+1
MOVEI T,UTOC
MOVEM T,UTIN+2
MOVEI A,↑C
PUSHJ P,UTTYO
.FDELE UTIN
UFRL: LERR [SIXBITCH \FILE RENAME LOST!\]
MOVE T,UTOBP
CAMN T,UTOIBP
JRST UFRL1
SKIPA TT,[↑C] ;PAD OUT WITH CONTROL-C'S
IDPB TT,T
TLNE T,740000
JRST .-2
HRLZS T
MOVSI TT,UTOB-1
SUB TT,T
HRRI TT,UTOB
.IOT UTOC,TT
UFRL1: .CLOSE UTOC,
] ;END OF IFN ITS
IFN D10,[
MOVEM T,D10REN ;MOVE FILENAME TO RENAME BLOCK
MOVEM T+1,D10REN+1
SETZB T,T+2
MOVE T+1,UWRT
OPEN DELC,T
JRST NODEV
MOVE T,D10REN
MOVE T+1,D10REN+1
SETZ T+2,
MOVE T+3,UWUSN
LOOKUP DELC,T ;FIND OLD FILE IF ANY
JRST D10NDL
SETZ T,
RENAME DELC,T ;DELETE ...
JRST D10DL1 ;ARG!
RELEASE DELC,
D10NDL: MOVE T,D10REN ;GET OLD NAME AGAIN
SETZ T+2,
MOVE T+3,UWUSN
TRZ T+1,-1
SA$ CLOSE UTOC, ;LOSING SAIL WON'T FORCE OUTPUT WITHOUT THIS
RENAME UTOC,T
LERR [SIXBIT \FILE RENAME LOST!\]
RELEASE UTOC,
] ;END OF IFN D10
MOVE A,UWUNIT
MOVEM A,IUNIT
SETZM UTOOPD
UNLKPOPJ
UFILE0: MOVEI A,QUFILE
PUSHJ P,NCONS
%FAC [SIXBIT \NO UWRITE FILE OPEN - UFILE!\]
IFN D10,[
D10DL1: MOVEI B,QUFILE
JRST UFLER
] ;END OF IFN D10
UKILL: JSP TT,FWNACK
FA0234,,QUKILL
MOVEI T,0
PUSH P,IUNIT
PUSHJ P,UINITA ;DOES A LOCKI
IFE D10,[
SETZM UTIN+3
.FDELE UTIN
JRST UKLER
] ;END OF IFE D10
IFN D10,[
MOVE T+1,UTIN ;PICK UP DEVICE NAME
SETZB T,T+2
OPEN DELC,T ;GET THE DEVICE
JRST UKLER
HLLZ T+1,UFN2 ;GET EXTENSION
MOVE T,UFN1
SETZ T+2,
MOVE T+3,USN
LOOKUP DELC,T
JRST UKLER
SETZB T,T+1 ;ZAP THE FILE NAME
RENAME DELC,T ;BYE
JRST UKLER
RELEASE DELC,
] ;END OF IFN D10
SUB P,R70+1
UNLKPOPJ
;;; IFE QIO
SUBTTL OLD I/O UWRITE
UWRITE: JSP TT,FWNACK
FA012,,QUWRITE
10% SKIPE UTOOPD
10% PUSHJ P,UWRT2
PUSHJ P,CRUNIT
LOCKI
SETOM UAPOS
IFE D10,[
MOVE T,[SIXBIT \.LISP.\]
MOVE TT,[SIXBIT \OUTPUT\]
MOVEM T,UTIN+1
MOVEM TT,UTIN+2
PUSHJ P,UTOINT
MOVEI T,3
UWRT0: HRLM T,UTIN ;UAPPEND JOINS IN HERE
MOVEM A,UWUNIT
TSOPEN UTOC,UTIN
MOVE T,UTIN
MOVEM T,UWRT
SKIPGE UAPOS
JRST UWRT3
.ACCESS UTOC,UAPOS
SETZM UTIN+1
MOVEI T,UTOC
MOVEM T,UTIN+2
MOVE T,[SIXBIT \.LISP.\]
MOVE TT,[SIXBIT \APPEND\]
MOVEM T,UTIN+3
MOVEM TT,UTIN+4
.FDELE UTIN
JRST UFRL
UWRT3:
] ;END OF IFE D10
IFN D10,[
MOVEM A,UWUNIT
SETZ T,
MOVE T+1,UTIN ;GET DEVICE
MOVEM T+1,UWRT
MOVSI T+2,UTOHED
OPEN UTOC,T
NODEV: LERR [SIXBIT \DEVICE NOT AVAILABLE!\]
UWRT0: MOVEI T,UTOB-3
EXCH T,.JBFF"
OUTBUF UTOC,1
EXCH T,.JBFF"
MOVE T,D10NAM
MOVSI T+1,(SIXBIT \OUT\)
SKIPL UAPOS
MOVSI T+1,(SIXBIT \APP\)
SETZ T+2,
MOVE T+3,USN
MOVEM T+3,UWUSN
ENTER UTOC,T ;MAKE THE FILE
NOENT: LERR [SIXBIT \CANNOT ENTER FILE!\]
SKIPL UAPOS
SA% USETI UTOC,-1 ;SAIL MOVE ACCESS POINTER TO END OF FILE
SA$ UGETF UTOC,SAILF2 ;SAIL MOVE ACCESS POINTER TO END OF FILE
] ;END OF IFN D10
AOS UTOOPD
JRST UEXIT
IFE D10,[
UWRT2: PUSH P,A
JSP T,SPECBIND
TAPWRT
MOVE T,[SIXBIT \.LISP.\]
MOVE TT,[SIXBIT \OUTPUT\]
PUSHJ P,UFILE1
PUSHJ P,UNBIND
JRST POPAJ
] ;END OF IFE D10
;;; IFE QIO
SUBTTL OLD I/O UAPPEND
UAPPEND: JSP TT,FWNACK
10% FA01234,,QUAPPEND
10$ FA0234,,QUAPPEND
10% PUSHJ P,UGREAT
10% SKIPE UTOOPD
10% PUSHJ P,UWRT2
PUSH P,IUNIT
10% MOVEI T,2
PUSHJ P,UINITA
IFE D10,[
.OPEN UTOC,UTIN
JRST UAPPER
.CALL UAFLEN
.VALUE
UAPP1: SUBI TT,1
.ACCESS UTOC,TT
MOVE T,[-1,,UTOB]
.IOT UTOC,T
MOVSI T,-5
MOVE D,UTOB
LSH D,-1
UAPP2: LSHC D,-7
LSH R,-35
JUMPE R,UAPP3
CAIE R,↑L
CAIN R,↑C
JRST UAPP3
PUSHJ P,UTOINT
HLRE D,T
ADDM D,UTOBYT
IMULI T,7
ADDI T,1
DPB T,[360600,,UTOBP]
MOVEM TT,UAPOS
MOVE A,IUNIT
SUB P,R70+1
MOVEI T,100003
JRST UWRT0
UAPP3: AOBJN T,UAPP2
JRST UAPP1
UAFLEN: SETZ
SIXBIT \FILLEN\
1000,,UTOC
402000,,TT
] ;END OF IFE D10
;;; IFE QIO
IFN D10,[ ;DROPS IN
SETZ D,
MOVE D+1,UTIN
MOVEM D+1,UWRT
MOVSI D+2,UTOHED
OPEN UTOC,D
JRST NODEV
TRZ T+1,-1
SETZ T+2,
MOVE T+3,USN
LOOKUP UTOC,T
JRST UAPPER
SETZB T,T+2
MOVE T+1,UWRT
OPEN DELC,T
JRST NODEV
MOVE T,D10NAM
MOVSI T+1,(SIXBIT \APP\)
SETZ T+2,
MOVE T+3,USN
LOOKUP DELC,T
JRST D10UAN
SETZ T,
RENAME DELC,T
JRST D10UAN
RELEASE DELC,
D10UAN: MOVE T,D10NAM
MOVSI T+1,(SIXBIT \APP\)
SETZ T+2,
MOVE T+3,USN
RENAME UTOC,T
JRST UAPPER
TRZ T+1,-1
SETZ T+2,
MOVE T+3,USN
LOOKUP UTOC,T
JRST UAPPER
MOVE A,IUNIT
SUB P,R70+1
MOVEM A,UWUNIT
SETZM UAPOS
JRST UWRT0
] ;END OF IFN D10
;;; IFE QIO
SUBTTL OLD I/O UREAD
UREAD: JSP TT,FWNACK
10% FA01234,,QUREAD
10$ FA0234,,QUREAD
10% PUSHJ P,UGREAT
PUSH P,IUNIT
IFE D10,[
MOVEI T,2 ;ORDINARY READ USES BLOCK ASCII INPUT
PUSHJ P,UINITA ;LOCKI DONE BY UINITA
.OPEN UTIC,UTIN
JRST UROER
] ;END OF IFE D10
IFN D10,[
PUSHJ P,UINITA
SETZ D,
MOVE D+1,UTIN ;GET DEVICE
MOVEI D+2,UTIHED
OPEN UTIC,D
JRST UROER
TRZ T+1,-1 ;FLUSH JUNK
SETZ T+2,
MOVE T+3,USN
LOOKUP UTIC,T ;IS THE FILE THERE?
JRST UROER
TRZ T+1,-1 ;FLUSH LOOKUP JUNK
MOVEM T,URFN1
MOVEM TT,URFN2
MOVE T,IUNIT
MOVEM T,URUNIT
MOVEI T,UTIB-3
EXCH T,.JBFF"
INBUF UTIC,1
EXCH T,.JBFF"
] ;END OF IFN D10
SUB P,R70+1
UREAD2:
10% MOVE T,[440700,,UTIB+UTBSIZ]
10% MOVEM T,UTIBP
MOVEI T,<↑C>←13
HRLZM T,UTIB+UTBSIZ
AOS UTIOPD
SKIPE ALGCF ;MUST AVOID CONSING WHILE IN ALLOC
JRST UEXIT
IFE D10,[
MOVE T,[UTIC,,URCHST] ;GET STATUS OF UREAD CHANNEL
.RCHST T,
MOVSI T,(SIXBIT \@\) ;IF DIDN'T GET FILE NAMES BACK,
SKIPN TT,URCHST+2 ; WANT TO USE @'S
SKIPA TT,T
MOVE T,URCHST+1
MOVEM T,URFN1 ;SAVE AS FILE NAMES FOR
MOVEM TT,URFN2 ; (STATUS UREAD)
HRRZ A,IUNIT
MOVE TT,URCHST+3 ;COMPARE DEV AND SNAME TO IUNIT
CAME TT,USN
JRST UREAD4
LDB T,[140600,,URCHST]
CAIE T,(SIXBIT \ UT\)
SKIPA T,URCHST
HRRZ T,URCHST
TLNE T,-1
HLRZS T
SUB T,UTIN
TRNN T,-1
JRST UREAD6
UREAD4: HRRZ A,(A) ;IF THEY DIFFER, MUST CONS UP URUNIT
JUMPE TT,UREAD5 ;IF NO SNAME, MUST BE FUNNY DEV - USE IUNIT'S SNAME
MOVE A,[440600,,URCHST+3] ;CONS UP SNAME
SETZM URCHST+4
PUSHJ P,READ6C
PUSHJ P,NCONS
UREAD5: PUSH P,A
MOVE A,[220600,,URCHST] ;CONS UP DEVICE NAME
SETZM URCHST+1
PUSHJ P,READ6C
POP P,B
PUSHJ P,CONS
UREAD6: MOVEM A,URUNIT ;SAVE UREAD UNIT
] ;END OF IFE D10
UEXIT: MOVE A,IUNIT
UNLKPOPJ
;;; IFE QIO
SUBTTL OLD I/O UCLOSE AND UPROBE
UCLOSE: SETZ T,
MOVEI D,QUCLOSE
JUMPN A,WNAFOSE
SKIPN A,UTIOPD
POPJ P,
JSP A,.UEOF
JRST TRUE
UPROBE: JSP TT,FWNACK
10% FA01234,,QUPROBE
10$ FA0234,,QUPROBE
10% PUSHJ P,UGREAT
HRRZ B,IUNIT
JSP T,SPECBIND
0 B,IUNIT
SAVEFX UFN1 UFN2
10% MOVEI T,2
PUSHJ P,UINITA
10% .OPEN ERRC,UTIN
IFN D10,[
SETZB D,D+2
MOVE D+1,UTIN
OPEN DELC,D
JRST UPROB3
TRZ T+1,-1
SETZ T+2,
MOVE T+3,USN
LOOKUP DELC,T
UPROB3:
] ;END OF IFN D10
TDZA A,A
MOVEI A,TRUTH
10% .CLOSE ERRC,
10$ RELEASE DELC,
JUMPE A,UPROB7
PUSH P,[440600,,UFN1]
MOVE A,[440600,,UFN2]
PUSHJ P,READ6C
HRRZ B,IUNIT
PUSHJ P,CONS
EXCH A,(P)
PUSHJ P,READ6C
POP P,B
PUSHJ P,CONS
UPROB7: UNLOCKI
RSTRFX UFN2 UFN1
JRST UNBIND
;;; IFE QIO
UINITA: PUSH P,A
10% HRLM T,(P)
UNTA1: MOVEI T,.
JUMPE A,UNTA2
HRRZ A,(A)
JUMPE A,UNTAER
HRRZ A,(A)
UNTA2: PUSHJ P,CRUNIT
LOCKI
MOVE A,(P)
10% HLLM A,UTIN
HRRZS A,(P)
PUSHJ P,UFNAME
10% MOVEM T,UTIN+1
10% MOVEM TT,UTIN+2
JRST POPAJ
UFNAME: JUMPE A,UFNM
PUSH P,A
MOVEI B,IN0+10.
JSP T,SPECBIND
0 B,VBASE
0 B,V.NOPOINT
UFNA1: HLRZ A,(A)
PUSHJ P,SIXMAK
HRRZ A,@(P)
MOVEI T,UFNA1
JUMPE A,UNTAER
MOVEM TT,UFN1
HLRZ A,(A)
SUB P,R70+1
PUSHJ P,SIXMAK
MOVEM TT,UFN2
PUSHJ P,UNBIND
UFNM: MOVE T,UFN1
MOVE TT,UFN2
POPJ P,
] ;END OF IFE QIO
SUBTTL SYMBOL MANIPULATION AND SQUOZE FUNCTIONS
GETDDTSYM:
10% JSP T,SIDDTP ;LOSE IF NO DDT FROM WHICH TO GET SYMBOL
10$ SKIPN .JBSYM" ;LOSE IF NO JOB SYMBOL TABLE
JRST FALSE
PUSHJ P,RSQUEEZE
$GETDDTSYM: ;SQUOZE IN TT - USED BY NON-DEC-10 FASLAP
10% .BREAK 12,[4,,TT]
10% JUMPE TT,FALSE
10% MOVE TT,TT+1
10$ PUSHJ P,GETDD0
10$ JRST FALSE
JRST FIX1
TTSR: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE (TTSR|)
MOVEI C,(A) ;SAVES AR1,R,F - SEE FASLOAD
PUSHJ P,ARGET
JUMPN A,TTSR1
JSP T,SACONS
MOVEI T,ADEAD
MOVEM T,ASAR(A)
MOVE T,[TTDEAD]
MOVEM T,TTSAR(A)
MOVEI B,(A)
MOVEI A,(C)
MOVEI C,QARRAY
PUSHJ P,PUTPROP
TTSR1: MOVSI T,TTS<CN>
IORM T,TTSAR(A)
MOVEI TT,1(A)
POPJ P,
RSQUEEZE: ;CANONICAL SQUOZE CONVERSION
10$ HRROS (P) ;FOR DEC-10, GIVES DEC-10 SQUOZE
SQUEEZE: ;THIS ALWAYS GIVES LEFT-JUSTIFIED SQUOZE
MOVEI AR1,6 ;CONVERT PNAME-ATOM TO SQUOZE AND SIXBIT
MOVE AR2A,[440600,,SQ6BIT] ;RETURNS SQUOZE IN TT, SIXBIT IN SQ6BIT
SETZM SQ6BIT ;CLEAR LOCS USED TO ACCUMULATE
SETZM SQSQOZ ; SIXBIT AND SQUOZE
HRROI R,SQZCHR
PUSHJ P,PRINTA ;"PRINT" OUT CHARS OR PNAME
IFN D10,[
MOVE TT,SQSQOZ
POP P,F
TLNE F,1
JRST (F)
SOJL AR1,(F)
IMULI TT,50
JRST .-2
] ;END OF IFN D10
IFE D10,[
SKIPA TT,SQSQOZ
IMULI TT,50 ;IF FEWER THAN 6 CHARS, MUST
SOJGE AR1,.-1 ; MULTIPLY ITS SQUOZE UP TO SIZE
POPJ P,
] ;END OF IFE D10
SQZCHR: TLNN AR2A,770000 ;IGNORE MORE THAN 6 CHARS
POPJ P,
SUBI A,40 ;CONVERT TO SIXBIT
CAIL A,1 ;LOSSAGE IF NOT SIXBIT CHAR
CAILE A,77 ; - ALSO, SPACE IS A LOSS
MOVEI A,'. ;LOSING NON-SQUOZE CHAR
IDPB A,AR2A ;DEPOSIT SIXBIT CHAR
CAIL A,'A ;CHECK FOR LETTER
CAILE A,'Z
JRST SQNOTL
SUBI A,'A-13 ;CONVERT TO SQUOZE VALUE
SQOK: EXCH T,SQSQOZ
IMULI T,50
ADDI T,(A)
EXCH T,SQSQOZ
SOJA AR1,CPOPJ ;DECR COUNT AND RETURN TO PRINTA
SQNOTL: CAIL A,'0 ;CHECK FOR DIGIT
CAILE A,'9
JRST SQNOTD
SUBI A,'0-1 ;CONVERT TO SQUOZE VALUE
JRST SQOK
SQNOTD: CAIE A,'$ ;CHECK FOR $ OR %
CAIN A,'%
JRST SQ%$
MOVEI A,'. ;ANY CHAR OTHER THAN A-Z, 0-9, $, OR %
DPB A,AR2A ; DEFAULTS TO . (E.G. *FOOBAR -> .FOOBA)
MOVEI A,45-42
SQ%$: ADDI A,42 ;SQUOZE VALUE FOR $,%,.
JRST SQOK
5BTWD: PUSH P,CFIX1
$5BTWD: PUSH FXP,R70
5BTWD0: MOVEI C,(A)
HRRZ B,(A)
JUMPE B,5BTWD1
HLRZ A,(A)
JSP T,FXNV1
LSH TT,-2
MOVEM TT,(FXP)
MOVEI A,(B)
5BTWD1: HLRZ A,(A)
JSP T,SPATOM
JRST 5BTWD9
PUSHJ P,SQUEEZE
MOVE R,SQ6BIT
POP FXP,D
DPB D,[400400,,TT]
POPJ P,
5BTWD9: SETZM (FXP)
MOVEI A,(C)
WTA [BAD ARG - SQUOZE!]
JRST 5BTWD0
UNSQOZ: LDB T,[004000,,D] ;HAIRY MESS TO CONVERT
SETZM LD6BIT ; SQUOZE TO SIXBIT
UNSQZ1: IDIVI T,50 ;(THIS IS SEPARATE ROUTINE SO
JUMPE TT,UNSQZ2 ; LAP LOSERS CAN USE IT)
CAIL TT,45 ;<1SQUOZE .>
JRST UNSQZ3
CAIL TT,13 ;<1SQUOZ A> IS 13
ADDI TT,'A-13 ;CONVERT RANGE A - Z ,
CAIGE TT,13 ;<1SQUOZ 1> IS 1
ADDI TT,'0-1 ;CONVERT RANGE 0 - 9
UNSQZ2: IOR TT,LD6BIT
ROT TT,-6
MOVEM TT,LD6BIT
JUMPN T,UNSQZ1
MOVE A,[440600,,LD6BIT] ;MAKE SIXBIT INTO AN ATOM
JRST READ6C
UNSQZ3: SUBI TT,46-'$ ;[1SQUOZ $] IS 46, [1SQOZ .] IS 45
CAIN TT,45-<46-'$> ;CONVERT RANGE $ - %
MOVEI TT,'* ;BUT . IS EXCEPTIONAL
JRST UNSQZ2
IFN D10,[
GETDD0: SKIPA D,.JBSYM" ;FIND SYMBOL IN JOB SYMBOL TABLE
GETDD1: ADD D,R70+2
JUMPGE D,CPOPJ
MOVE T,(D)
TLZ T,540000
TLZN T,200000 ;SYMBOL MUSTN'T BE KILLED
CAME T,TT ;MUST BE THE ONE WE WANT
JRST GETDD1
MOVE TT,1(D)
AOJA D,POPJ1
] ;END OF IFN D10
PUTDDTSYM:
MOVEI R,0 ;PUTDDTSYM| IS FOR LAP - OFFSETS VALUE BY LOAD OFFSET
PUTDD0:
10% JSP T,SIDDTP ;LOSE IF NO DDT TO GIVE SYMBOL TO
10$ SKIPN .JBSYM"
JRST FALSE
PUSH FXP,R
PUSH P,B
10$ SKIPL R ;SEE LDPUT1
PUSHJ P,RSQUEEZE ;SQUEEZE ATOM'S PNAME DOWN TO SQOUZE CODE
POP P,B
10% .BREAK 12,[3,,D]
POP FXP,R
10% JUMPE D,FALSE
IFE ITS,[
PUSHJ P,GETDD0
JRST PUTDD4
MOVEI F,(D)
] ;END OF IFE ITS
PUTDD2: JSP T,FXNV2 ;GET VALUE OF SECOND ARG
ADDI D,(R) ;ADD IN OFFSET
10% .BREAK 12,[400004,,TT]
10$ MOVEM D,(F)
JRST TRUE
IFN D10,[
PUTDD4: SOSGE SYMLO
JRST FALSE
MOVE F,R70+2
SUBB F,.JBSYM"
TLO TT,100000 ;LOCAL SYMBOL
MOVEM TT,(F)
AOJA F,PUTDD2
] ;END OF IFN D10
SUBTTL LAPSETUP AND FASLAPSETUP
LAPSETUP: JUMPN A,LAPSMH ;ARG = NIL => SETUP SOME SYM PROPERTIES
MOVEI T,LAPST2
LAP5HAK: PUSH P,T ;APPLIES THE ROUTINE FOUND IN T TO ALL THE GLOBALSYMS
PUSH P,[441100,,LAP5P] ;ATOMIC SYMBOL PLACED IN A, GLOBALSYM INDEX IN TT
MOVSI F,-LLSYMS
L5H1: ILDB TT,(P) ;HAFTA GET THE GLOBALSYM INDEX FROM PERMUTATION TABLE
CAIL TT,LGSYMS ;IF THIS IS NOT A GLOBALSYM [BUT AN XTRASYM], SKIP IT
JRST L5XIT
CAIN TT,3 ;SO NEVER, BUT NEVER CHANGE THE GLOBALSYM INDICES FOR
JRST L5SPBND ; SPECBIND 3
CAIN TT,25 ; ERSETUP 25
JRST L5ERSTP ; MAKUNBOUND 34
CAIN TT,34 ; INHIBIT 47
JRST L5MKUNBD ; 0*0PUSH 53
CAIN TT,47 ; NILPROPS 54
JRST L5INHIBI ;THOSE GUYS HAVE MORE THAN 6 CHARS IN THEIR PNAME
CAIN TT,53 ;AND CANT BE RECONSTRUCTED BY UNSQOZ'ING FROM
JRST L50.0P ;FROM THE LAPFIV TABLE
CAIN TT,54
JRST L5NILP
MOVE D,LAPFIV(F)
PUSHJ P,UNSQOZ
L5H2: LDB TT,(P)
PUSHJ P,@-1(P)
L5XIT: AOBJN F,L5H1
JRST POP2J
L5ERSTP: MOVEI A,[SIXBIT \ERSETUP \]
JRST L5H3
L5SPBND: MOVEI A,[SIXBIT \SPECBIND \]
L5H3: HRLI A,440600
PUSHJ P,READ6C
JRST L5H2
L5MKUNBD: MOVEI A,[SIXBIT \MAKUNBOUND \]
JRST L5H3
L5INHIBIT: MOVEI A,[SIXBIT \INHIBIT \]
JRST L5H3
L50.0P: MOVEI A,[SIXBIT \0*0PUSH \]
JRST L5H3
L5NILP: MOVEI A,[SIXBIT \NILPROPS\]
JRST L5H3
LAPSMH: CAIE A,TRUTH ;(LAPSETUP| T 2) MEANS
JRST LAPSM1 ; SET UP THE XCT HACK AREAS
JSP T,FXNV2 ; WITH 2 XCT PAGES
MOVE TT,D
JRST LDXHAK
LAPSM1: MOVEI T,(B) ;OTHERWISE, FIRST ARG IS ADDRESS
MOVEI R,(A) ; TO HACK, SECOND NON-NIL =>
MOVE TT,(R) ; TRY THE XCT-PAGE HAK
PUSHJ P,PRCHAK ;TRY TO SMASH (SKIP ON FAILURE)
JRST TRUE
MOVEI A,(AR2A)
MOVE B,VPURCLOBRL
PUSHJ P,CONS
MOVEM A,VPURCLOBRL
JRST TRUE
IFE QIO,[
FSLSTP:
JUMPE A,FSLST1 ;ARG = NIL => INITIALIZING FASLAP
MOVE F,[-LFLSYMS,,FLSYMS] ;ARG=T => LOADING IN A FASLAP
SKIPA A,[440600,,FLAPSIX]
LSUP3A: MOVE A,CORBP ;CLOBBER IN SOME SYM PUTPROPS
LSUP3: PUSHJ P,READ6C
HRRZ TT,(F)
PUSHJ P,LSYMPUT
AOBJN F,LSUP3A
JRST TRUE
] ;END OF IFE QIO
LAPST2: MOVE TT,LSYMS(TT) ;GET ACTUAL VALUE FROM GLOBALSYM INDEX
LSYMPUT: MOVEI B,(A) ;EXPECTS SYMBOL IN A, VALUE IN TT
JSP T,FXCONS
LSMPT1: EXCH A,B
MOVEI C,QSYM
JRST PUTPROP
Q% FSLST1:
Q$ FSLSTP:
MOVEI T,FSLST2
PUSHJ P,LAP5HAK
MOVE TT,LDFNM2
JRST FIX1
FSLST2: MOVEI C,(A) ;MAKE UP ATOMIC SYMBOLS AND GIVE THEM SYM PROPERTIES
JSP T,FXCONS ; OF THE FORM (0 (NIL <N>))
PUSHJ P,NCONS ; WHERE <N> IS THE INDEX OF THE SYMBOL
SETZ B, ; (THESE ARE THE "GLOBALSYMS")
PUSHJ P,XCONS
PUSHJ P,NCONS
MOVE B,CIN0
PUSHJ P,XCONS
MOVEI B,(C)
JRST LSMPT1
IFE QIO,[
DEFINE FLSYM B
IRP A,,[DSIC]
B
TERMIN
IFN D10,[
IRP A,,[IOO,D10NAM,UFN1,UFN2,USN]
B
TERMIN
] ;END OF IFN D10
TERMIN
FLSYMS: FLSYM A
LFLSYMS==.-FLSYMS
FLAPSIX: .BYTE 6
FLSYM [IRPC Q,,[A]
'Q
TERMIN
0 ]
.BYTE
] ;END OF IFE QIO
R70 ;GLOBALSYM NUMBER -1
LSYMS: GLBSYM A
LGSYMS==.-LSYMS ;END OF GLOBALSYMS HACKED BY FASLAP
XTRSYM A
LLSYMS==.-LSYMS ;END OF ALL GLOBAL SYMBOLS
;;; SIXBIT FOR LAP SYMBOL NAMES; MUST MATCH IRP LIST OF GLBSYM
ZZ==0
LAPSIX: .BYTE 6
SIXSYM [
IRPC Q,,[A]
'Q
TERMIN
0
ZZ==ZZ+1
] ;END OF SIXSYM ARGUMENT
.BYTE
IFN ZZ-LGSYMS, WARN [LAPSIX OUT OF PHASE]
EXPUNGE ZZ
LAPFIV:
GLBSYM [SQUOZE 0,A]
XTRSYM [SQUOZE 0,A]
HAOLNG LOG2LL5,<LLSYMS-1> ;CROCK FOR BINARY SEARCH
REPEAT <1←LOG2LL5>-LLSYMS, 377777,,777777
LAP5P: BLOCK <LLSYMS+3>/4 ;PERMUTATION, STORED 4/WD, TO GET GLOBALSYMINDEX FROM LAPFIV INDEX
LGTSPC: MOVEM TT,GAMNT
ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT)
SUB TT,@VBPEND
JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE.
MOVE A,VBPEND ;ALREADY OK
MOVE TT,(A)
POPJ P,
PAGEBPORG: MOVE A,VBPORG ;MAKE SURE BPORG IS ON PAGE BOUNDRY
MOVE TT,(A) ;NUMERIC VALUE OF BPORG
TRNN TT,PAGKSM
POPJ P,
ADDI TT,PAGSIZ-1
ANDCMI TT,PAGKSM
CAMGE TT,@VBPEND
JRST PGBP4
PUSH FXP,TT ;NEW VALUE FOR BPORG
JSP T,SPECBIND
0 VNORET
AOS VNORET
PUSH P,CUNBIND
SUB TT,(A)
PUSHJ P,LGTSPC
JUMPE TT,[LERR [SIXBIT \NO CORE - PAGEBPORG!\]]
POP FXP,TT
PGBP4: JSP T,FIX1A
MOVEM A,VBPORG ;GIVE BPORG NEW PAGIFIED VALUE
POPJ P,
SUBTTL MAKUNBOUND
MAKUBE: %WTA [SIXBIT \UNCHANGEABLE VALUE - MAKUNBOUND!\]
MAKUNBOUND: ;SUBR 1 - FLUSH VALUE OF ATOMIC SYMBOL
BAKPRO
JSP D,SETCK ;MAKE SURE IT'S A SYMBOL
JUMPE A,MAKUBE
CAIN A,TRUTH
JRST MAKUBE
HLRZ T,(A)
MOVE B,(T)
TLNE B,300 ;CAN'T RECLAIM VALUE CELL IF PURE
JRST MAKUN1 ; OR IF COMPILED CODE NEEDS IT
TLZ B,-1
CAIN B,SUNBOUND ;CAN'T RECLAIM SUNBOUND!!!
POPJ P,
CAIL B,BXVCSG+NXVCSG*SEGSIZ
JRST MAKUN1 ;CAN'T RECLAIM CELL NOT IN VALUE CELL AREA
EXCH B,FFVC ;SO RECLAIM THE VALUE CELL ALREADY
XCTPRO
MOVEM B,@FFVC
MOVEI B,SUNBOUND ;USE SUNBOUND FOR A VALUE CELL
HRRM B,(T)
NOPRO
POPJ P, ;THAT'S ALL
MAKUN1: PUSH P,A ;MAKE SURE WE RETURN THE ARGUMENT
PUSH P,CPOPAJ
MOVEI B,QUNBOUND ;FALL INTO SET WITH "UNBOUND" VALUE
JRST SET+1
SUBTTL MULTIPLEXOR I/O FUNCTIONS
IFN MOBIOF,[
MPX: JUMPE A,MPX1 ;FIRST ARG FOR IMXC
SOJE A,CIMX ;SECOND FOR OMXC
SOSE A ; NIL - DO NOTHING
MOVSI A,4 ; 0 - CLOSE CHANNEL
HRRI A,(SIXBIT \IMX\) ; 1 - OPEN IN NORMAL MODE
TSOPEN IMXC,A ; 2 - OPEN IN FAST MODE (ASCII)
AOS IMXOPD
MPX1: JUMPE B,TRUE
SOJE B,COMX
SOSE B
MOVEI B,4
HRLZI B,1(B)
HRRI B,(SIXBIT \OMX\)
TSOPEN OMXC,B
AOS OMXOPD
JRST TRUE
CIMX: .CLOSE IMXC,
SETZM IMXOPD
JRST MPX1
COMX: .CLOSE OMXC,
SETZM OMXOPD
JRST TRUE
OMPX: SKIPN OMXOPD
LERR [SIXBIT \OMX NOT OPENED!\]
JSP T,FXNV1
DPB TT,[360600,,R]
JSP T,FXNV2
DPB D,[221400,,R]
.IOT OMXC,R
POPJ P,
IMPX: SKIPN IMXOPD
LERR [SIXBIT \IMX NOT OPENED!\]
JSP T,FXNV1
.IOT IMXC,TT
JRST FIX1
OPNGEN IMX,0
OPNGEN OMX,1
] ;END OF IFN MOBIOF
IFN USELESS,[
SUBTTL PURIFICATION RITES
$PURIFY:
IFN D10, POPJ P,
IFE D10,[
SETZ AR1,
JSP T,FXNV1 ;GET TWO MACHINE NUMBERS
JSP T,FXNV2
ANDCMI TT,1777 ;PAGIFY FIRST DOWNWARD
IORI D,1777 ;PAGIFY SECOND UPWARD
CAMLE TT,D
LERR [SIXBIT \ARG 2 < ARG 1 - PURIFY!\]
JUMPE C,FPURF3 ;NULL THIRD ARG MEANS DEPURE
HLRZ T,LDXBLT ;CHECK TO SEE IF PURIFYING XCT CALL PAGES
JUMPE T,FPURF0
CAML T,TT
CAMLE T,D
JRST FPURF0
MOVSI T,400000
IORM T,LDXSIZ ;IF SO, SET FLAG - CAN'T ADD NEW CALLS TO THOSE PAGES
FPURF0: CAIE C,QBPORG
JRST FPURF3
FPURF7: MOVSI F,2000 ;THIS BIT CONVERTS CALL TO CALLF, JCALL TO JCALLF
MOVEI T,VPURCL
PUSH P,T
FPURF1: HRRZ T,(T) ;CDR DOWN THE PURLIST
FPUR1Q: JUMPE T,FPURF2
FPUR1A: HLRZ AR2A,(T)
PUSHJ P,LDSMSH ;TRY TO SMASH
JRST FPURF4 ;WIN
IORM F,(AR2A) ;LOSE - MAKE IT A CALLF/JCALLF
FPURF4: HRRZ T,@(P) ;WIN, SO CUT IT OUT OF PURCLOBRL
HRRZ T,(T)
HRRM T,@(P)
JRST FPUR1Q
FPURF3: JSP R,IP0
POPJ P,
] ;END OF IFE D10
IP0: ;PURIFY/DEPURIFY SOME PAGES
IFN D10, JRST (R)
IFE D10,[
LSH D,-PAGLOG ;CALLED BY JSP R,IP0
LSH TT,-PAGLOG ;USES B,C,T,TT,D,F
CAIGE TT,1
LERR [SIXBIT \1ST PAGE NOT PURE!\]
MOVEI B,(TT) ;FOR BIBOP, FIGURE OUT BYTE
ROT B,-4 ; POINTER FOR UPDATING PURTBL
ADDI B,(B)
ROT B,-1
TLC B,770000
ADD B,[450200,,PURTBL]
SUBI D,-1(TT) ;CALCULATE NUMBER OF PAGES
IMULI TT,1001
TRO TT,400000 ;SET UP ARG FOR .CBLK
SKIPN C
TLOA TT,400
SKIPA C,R70+2 ;FOR BIBOP, 1=IMPURE, 2=PURE
MOVEI C,1 ; IN PURTBL ENTRY
IP7: .CBLK TT, ;HACK PAGE
JSP F,IP1 ;IP1 HANDLES LOSSES
ADDI TT,1001
TLNN B,730000 ;FOR BIBOP, DEPOSIT BYTE IN PURTBL
TLZ B,770000
IDPB C,B
SOJN D,IP7
JRST (R)
IP1: MOVE T,[4400,,776000] ;ASSUME FAILURE WAS DUE TO SHARING
.CBLK T, ;USES ONLY T,TT
.LOSE 1000+%ENACR ;NO CORE AVAILABLE
LDB T,[111000,,TT]
LSH T,PAGLOG+22
HRRI T,376*PAGSIZ ;SO COPY PAGE INTO SOME FAKE PAGE
BLT T,376*PAGSIZ+1777 ;LIKE PAGE NUMBER 376
MOVE T,TT
ANDCMI T,377
IORI T,376
.CBLK T, ;MOVE PAGE MAP FOR 376 INTO LOSING PAGE POSITION
.VALUE
MOVEI T,376000
.CBLK T, ;FLUSH ENTRY FOR PAGE 376
.VALUE
JRST (F)
;;; IFN USELESS
;;; IFE D10
IPUR9: SETZ
SIXBIT \CORTYP\
1000,,400(R)
402000,,T
UNPURIFY: ;UNPURIFY ALL PAGES (MOSTLY FOR JPG)
MOVNI R,NPAGS ;DO *NOT* MUNG PURTBL!!!
MOVE TT,[0400,,400000]
UNPUR1: .CALL IPUR9
.VALUE
JUMPLE T,UNPUR2
.CBLK TT,
JSP F,IP1
UNPUR2: ADDI TT,1001
AOJL R,UNPUR1
.VALUE [ASCIZ \:≠UNPURIFIED≠
\]
] ;END OF IFE D10
] ;END OF IFN USELESS
SUBTTL 100$G RESETS THE WORLD!
GOINIT:
10% .SUSET [.S40ADDR,,[TWENTY,,FORTY]] ;SET .40ADDR
MOVEI A,READTABLE
MOVEM A,VREADTABLE
IFN USELESS,[
MOVE A,[RCT0,,RCT]
BLT A,RCT+LRCT-1 ;RESTORE READ CHARACTER SYNTAX TABLE
] ;END OF IFN USELESS
IFE QIO,[
IFN D10,[
PUSHJ P,SIXJBN
MOVE TT,D10NAM
MOVEM TT,UFN1
MOVSI TT,(SIXBIT \TMP\)
MOVEM TT,UFN2
] ;END OF IFN D10
IFE D10,[
MOVSI TT,(SIXBIT \@\)
MOVEM TT,UFN1
MOVEM TT,UFN2
MOVE TT,[GOINI9,,STTYS1]
BLT TT,STTYS2
] ;END OF IFE D10
] ;END OF IFE QIO
IFN EDFLAG,[
SETZM VDLDLDL
SETZM EDUPLST
SETZM EDSRCH
] ;END OF IFN EDFLAG
IFN QIO,[
MOVEI A,TTYIFA
MOVEM A,V%TYI
MOVEI A,TTYOFA
MOVEM A,V%TYO
MOVEI A,TRUTH
MOVEM A,VINFILE
SETZM VINSTACK
SETZM VOUTFILES
SETZM VECHOFILES
MOVEI A,QTLIST
MOVEM A,VMSGFILES
IFN USELESS,[
MOVEI T,IB<MAR> ;RESET THE MAR BREAK FEATURE
ANDCAM T,INTMSK
.SUSET [.SAMASK,,T]
.SUSET [.SMARA,,R70]
] ;END OF IFN USELESS
] ;END OF IFN QIO
MOVEI A,OBARRAY
MOVEM A,VOBARRAY ;GET BACK TOPLEVEL OBARRAY
Q% SETZM VPRIN1
Q$ SETZM V%PR1
SETZM VOREAD
SETZM TLF
SETZM BLF ;??
SETZM UNRC.G ;CLEAR STACKED NOINTERRUPT STUFF
SETZM UNRRUN
SETZM UNRTIM
SETZM UNREAR
SETZM TTYOFF
JSP A,ERINIT
GOINI7: SETZB A,VERRLI ;NULLIFY ERRLIST
PUSHJ P,INTERN
JUMPE A,LISPGO
PUSHJ P,REMOB2 ;GET STANDARD COPY OF NIL ON OBLIST
JRST GOINI7
IFE QIO+D10,[
GOINI9: STTYW1 ;INITIAL TTY STATUS WORDS
STTYW2
] ;END OF IFE QIO
;;; UTAPESTUFF, LAPSTUFF, AND SYSP, MPX, COPYSYMBOL, PURIFY, GOINIT
PGTOP UIO,[UTAPE, LAP, AND AGGLOMERATED SUBRS]
;;@ END OF ULAP 80
;;@ ARITH 47 STANDARD ARITHMETIC FUNCTIONS
PGBOT ARI
;THE ARITHMETIC PAGE - ARITHMETIC SUBROUTINES
IFN BIGNUM,[
SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==1
ZEROP: MOVEI R,2
JRST ZMP
MINUSP: TDZA R,R
PLUSP: MOVEI R,1
ZMP: JSP T,NVSKIP
JRST .+2
JFCL
XCT .+2(R)
JRST FALSE
JUMPL TT,TRUE ;FOR MINUSP
JUMPG TT,TRUE ;FOR PLUSP
JUMPE TT,TRUE ;FOR ZEROP
MINUS: JSP T,NVSKIP
JRST MNSBG
JRST MNSFX
MOVNS TT
JRST FLOAT1
MNSFX: CAMN TT,[400000000000]
JRST ABSOV
MOVNS TT
JRST FIX1
ADD1: MOVEI R,1
JRST SUB11
SUB1: MOVNI R,1
SUB11: JSP T,NVSKIP
JRST A1S1BG
JRST A1S1FX
JUMPL R,.+3
FAD TT,[1.0]
JRST FLOAT1
FSB TT,[1.0]
JRST FLOAT1
A1S1FX: CAMN TT,[1←43]
JUMPL R,A1S11
ADD TT,R
CAMN TT,[1←43] ;DONT WANT TO GET -2E35. BY ADD1
JUMPG R,ABSOV
JRST FIX1
A1S11: PUSHJ P,ABSOV ;CANT SUB1 FROM -2E35. AND
HRROS (A)
A1S1BG: PUSH P,B ;ADD1 AND SUB1 FOR BIGNUM
PUSH P,CPOPBJ
MOVEI B,IN1
JUMPL R,.DIF
JRST .PLUS
ABSOV: PUSH P,B ;OVERFLOW FROM ADD1, SUB1, ABS,
MOVEI TT,1 ; MINUS, HAIPART, GCD, ETC.
PUSHJ P,C1CONS
MOVE B,A
MOVEI TT,0
PUSHJ P,C1CONS
HRRM B,(A)
PUSHJ P,BNCONS
JRST POPBJ
;;; MOBY DISPATCH TABLES FOR THE VARIOUS ARITHMETIC OPERATIONS
CAIA
. ;UNUSED WORD
JRST GRSWF
COMPR: JRST GRSWX
JFCL 0
JRST GRBFX
JRST GRFXB
JRST GRBB
SKIPE VZFUZZ
0
FSBR D,TT
DIFFA: SUB D,TT
JRST PLOV
JRST PL2BN
JRST PL1BN
JRST BNDF
SKIPE VZFUZZ ;-3(R) SKIP UNLESS FUZZ HACK TO BE PULLED
0 ;-2(R) OPERATION IDENTITY - VALUE WHEN NO ARGS GIVEN
FADR D,TT ;-1(R) FLOATING POINT INSTRUCTION FOR OPERATION
PLUSA: ADD D,TT ;0(R) FIXED POINT INSTRUCTION FOR OPERATION
JRST PLOV ;1(R) ACTION ON ARITHMETIC OVERFLOW
JRST PL2BN ;2(R) BIGNUMBER ACCUMULATION MEETS FIXNUM ARG
JRST PL1BN ;3(R) FIXNUM ACCUMULATION MEETS BIGNUM ARG
JRST BNPL ;4(R) BIGNUM ACCUMULATION, BIGNUM ARG
CAIA
1
FMPR D,TT
TIMESA: IMUL D,TT
JRST TIMOV
JRST TIM2BN
JRST TIM1BN
JRST BNTIM
CAIA
1
FDVR D,TT
QUOA: JRST QUOAK
JRST QUOOV
JRST DV2BN
JRST DV1BN
JRST BNDV
QUOOV: SKIPN RWG
JRST OVFLER
AOS D,T
JFCL 8.,PLOV
JRST T14E
QUOAK: CAMN D,[400000,,0] ;ORDINARY FIXED POINT DIVISION
JRST QUOAK1
QUOAK2: IDIVM D,TT
MOVE D,TT
JRST T14EX2
QUOAK1: CAME TT,XC-1
JRST QUOAK2
JRST DIVSEZ
T1: JUMPE T,NMCK0 ;ONLY ONE ARG GIVEN - GIVE IT OUT
MOVE TT,-2(R) ;NO ARGS GIVEN - GIVE OUT OPERATORS IDENTITY
JRST FIX1
.QUO: SKIPA R,[QUOA] ;C KEEPS ADDRESS OF FUNCTION TYPE
.TIMES: MOVEI R,TIMESA
SETZM REMFL
JRST T21
.DIF: SKIPA R,[DIFFA]
.PLUS: MOVEI R,PLUSA
T21: MOVNI T,1
PUSH P,A
PUSH P,B
JRST T20
QUOTIENT: SKIPA R,[QUOA]
TIMES: MOVEI R,TIMESA
SETZM REMFL
JRST T22
DIFFERENCE: SKIPA R,[DIFFA]
PLUS: MOVEI R,PLUSA
T22: AOJGE T,T1
T20: MOVE F,T ;D - ACCUMULATED VALUE
ADDI F,1(P) ;TT - NEXT VALUE IN LINE
HRL F,T
T24: MOVNI T,-1(T)
HRLS T ;R - ADDRESS OF INSTRUCTION DISPATCH TABLE
MOVEM T,PLUS8 ;F - AOBJN POINTER TO ARG VECTOR ON PDL
MOVE A,-1(F)
JSP T,NVSKIP ;PICK UP FIRST ARG AND DISPATCH TO APPROPRIATE LOOP
JRST T2
JRST T3
MOVE D,TT
JRST 2,@[.+1]
T4: MOVE A,(F) ;FLOATING POINT ARITHMETIC LOOP
JSP T,NVSKIP
JRST T6
JRST T5
T7: XCT -1(R) ;FLOATING SUM OPERATED WITH FLOATING NEXT ARG
XCT -3(R) ;SKIP UNLESS ZFUZZ HACK REQUIRED
JSP A,ZFZCHK
T7A: AOBJN F,T4
JFCL 8.,T7O
T7X: MOVE TT,D ;EXIT ARITHMETIC LOOP WITH ACCUMULATED VALUE
T7X1: SUB P,PLUS8
JRST FLOAT1
T7O: JSP T,T7O0
JRST T7X1
ZFZCHK: MOVE T,D
JRST 2,@[.+1]
FDVR T,TT
JFCL 8,ZFZCH9
MOVM T,T
CAMGE T,@VZFUZZ
SETZ D,
ZFZCH9: JRST 2,(A) ;DON'T LET FDVR AFFECT OVERFLOW/UNDERFLOW
;;; IFN BIGNUM ;ARITH OPS FOR BIGNUM==1 CONTINUED
T5: EXCH D,AGDBT
JSP T,IFLOAT ;FLOATING SUM, NEXT IS FIXED POINT
EXCH D,AGDBT
JRST T7
T6: CAIN R,QUOA
JRST T6A
PUSHJ P,FLBIG ;FLOATING SUM, NEXT WAS BIGNUM
JRST T7
T6A: PUSHJ P,FLBIGQ ;SPECIAL HACK FOR JPG
JRST T7
SETZ D, ;IF BIGNUM TOO LARGE, WE GET
JRST T7A ; UNDERFLOW, NOT OVERFLOW
T3: MOVE D,TT ;FIXED POINT ARITHMETIC LOOP
JRST 2,@[.+1]
T15: MOVE A,(F)
JSP T,NVSKIP
XCT 3(R) ;DISPATCH TO CONVERT SUM TO BIGNUM
JRST T14 ;OPERATE ON TWO FIXED POINT
MOVEM TT,AGDBT
MOVE TT,D ;FIXED POINT SUM CONVERTED TO FLOATING
JSP T,IFLOAT ;AND ENTER FLOATING LOOP
MOVE D,TT
MOVE TT,AGDBT
JRST T7 ;IFLOAT CANNOT HAVE SET OFVLO FLG
T14: MOVE T,D ;SAVE OLD SUM, JUST INCASE THERE IS OVERFLO
XCT 0(R) ;OPERATE FIXED POINT
T14EX2: JFCL 8,1(R) ;CHECK FOR OVERFLO, IF SO DISPATCH TO BIGNUM
T14E: AOBJN F,T15
T14EX: MOVE TT,D
T14EX1: SUB P,PLUS8
JRST FIX1
ABS: JSP T,NVSKIP
JRST ABSBG
SKIPA T,CFIX1
MOVEI T,FLOAT1
JUMPGE TT,PDLNMK
CAMN TT,[1←43] ;ABS OF -2**35. IS NO LONGER FIXNUM
JRST ABSOV
MOVMS TT
JRST (T)
REMAINDER: SETZB F,PLUS8
JSP T,NVSKIP
JRST REMBIG
SKIPA D,TT
JSP T,REMAIR
EXCH A,B ;FIRST ARG IS FIXNUM
JSP T,NVSKIP
JRST REMAI2 ;IF SECOND IS BIGNUM NOW, GIVE OUT FIRST
SKIPA T,D
JSP T,REMAIR
JUMPE TT,BPDLNKJ
IDIV T,TT
JRST FIX1
REMAI2: SKIPL T,(B) ;WELL, IF FIRST ARG IS SETZ, AND
JRST BPDLNKJ ; SECOND ARG IS +SETZ, THEN REMAINDER
CAME T,[400000,,] ; SHOULD BE 0, NOT SETZ!
JRST BPDLNKJ
MOVE A,(A)
PUSH P,AR1 ;MUST SAVE AR1
PUSHJ P,BNTRS1 ;SKIPS 2 UNLESS BIGNUM IS
POP P,AR1 ; +SETZ (OR SETZ)
JRST 0POPJ
POP P,AR1
JRST BPDLNKJ
FLOAT: TDZA R,R
MOVEI R,TRUTH
JSP T,NVSKIP
JRST FLBIGF
JRST FLOAT4
FIX4: JUMPE R,PDLNKJ ;ARG IS ALREADY OF REQUIRED TYPE. IF "CALL"ED, THEN RETURN LISP ANSWER IN A
POPJ P, ;ELSE IF "NCALL"ED, RETURN NUMERIC ANSWER IN TT
FLOAT4: JSP T,IFLOAT
JUMPE R,FLOAT1
POPJ P,
$IFIX: TDZA R,R
MOVEI R,TRUTH
JSP T,FLTSKP
JRST FIX4
JRST FIX25
FIX: TDZA R,R
MOVEI R,TRUTH
JSP T,NVSKIP
POPJ P,
JRST FIX4
FIX25: MOVM T,TT
CAML T,[244000,,]
JRST FIXBIG
JSP T,IFIX
JUMPE R,FIX1
POPJ P,
.GREAT: EXCH A,B
.LESS: PUSH P,A
PUSH P,B
MOVNI T,2
LESSP: SKIPA A,[CAML D,2]
GREATERP: HRLZI A,(CAMG D,)
MOVEI D,GRFAIL
MOVEI R,GRSUCE
GTR1: MOVE F,T
AOJGE T,GTR9
HRRI A,TT
ADDI F,2(P)
HRLI F,(T)
PUSHJ FXP,SAV5M2
HRLI D,(JRST)
MOVEM D,CFAIL
HRLI R,(JRST)
MOVEM R,CSUCE
MOVEI R,COMPR
MOVEM A,GRESS0
JRST T24
GTR9: MOVEI D,QMAX+1(A)
SOJA T,WNALOSS
MIN: SKIPA A,[CAML D,1]
MAX: HRLOI A,(CAMG D,)
AOJE T,NMCK0
MOVEI D,MXF
MOVEI R,MXS
SOJA T,GTR1
MXF: MOVE AR1,AR2A
SKIPA D,TT
MXS: MOVE AR2A,AR1
AOBJN F,GRSUC1
MAXFIN: MOVEI B,(AR1)
PUSHJ FXP,RST5M2
2DIF JRST @(B),MAX923,QFIXNUM
MAX923: T14EX ;FIXNUM
T7X ;FLONUM
T13X ;BIGNUM
GRSUC2: MOVE D,TT
GRSUC1:
2DIF JRST @(AR2A),GRS923,QFIXNUM
GRS923: T15 ;FIXNUM
T4 ;FLONUM
T12 ;BIGNUM
GRSUCE: AOBJN F,GRSUC2
GRSFIN: MOVEI A,TRUTH
GRSF1: PUSHJ FXP,RST5M2
SUB P,PLUS8
POPJ P,
GRFAIL: MOVEI A,NIL
JRST GRSF1
GRSWF: SKIPA AR1,[QFLONUM]
GRSWX: MOVEI AR1,QFIXNUM
MOVE AR2A,AR1
JRST GRESS0
] ;END OF ARITH OPS WITH BIGNUM==1
IFE BIGNUM,[
SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==0
ADD1: JSP T,FLTSKP
AOJA TT,FIX1
FAD TT,[1.0]
JRST FLOAT1
SUB1: JSP T,FLTSKP
SOJA TT,FIX1
FSB TT,[1.0]
JRST FLOAT1
REMAINDER: JSP T,FXNV1
JSP T,FXNV2
IDIV TT,TT+1
MOVE TT,TT+1
JRST FIX1
MINUS: JSP T,FLTSKP
SKIPA T,CFIX1
MOVEI T,FLOAT1
MOVNS TT
JRST (T)
ABS: JSP T,FLTSKP
SKIPA T,CFIX1
MOVEI T,FLOAT1
MOVMS TT
JRST (T)
MINUSP: SKIPA R,[JUMPGE TT,FALSE]
PLUSP: MOVE R,[JUMPLE TT,FALSE]
JSP T,FLTSKP
JFCL
XCT R
JRST TRUE
ZEROP: JSP T,FLTSKP
JFCL
JUMPE TT,TRUE
JRST FALSE
$IFIX:
FIX: TDZA R,R
MOVEI R,TRUTH
JSP T,FIXFLO
TLNN T,FL ;FIXFLO LEFT TYPE BITS IN T
JRST FIX4
JSP T,IFIX
JUMPE R,FIX1
POPJ P,
FIX4: JUMPE R,PDLNKJ
POPJ P,
FLOAT: TDZA R,R
MOVEI R,TRUTH
JSP T,FIXFLO
TLNN T,FX ;FIXFLO LEFT TYPE BITS IN T
JRST FIX4
JSP T,IFLOAT
JUMPE R,FLOAT1
POPJ P,
FIXFLO: PUSH P,A
LSH A,-SEGLOG
HLL T,ST(A) ;LEAVES TYPE BITS IN T
TLNN T,FX+FL
JRST FLOAT3
POP P,A
JRST (T)
FLOAT3: POP P,A
%WTA NMV3
JRST FIXFLO
MIN: SKIPA A,[CAMLE F,1]
MAX: HRLOI A,(CAMGE F,)
AOJE T,NMCK0
MOVEI D,MINMAX
SOJA T,MNMX1
MINMAX: XCT MNMX0 ;CAMG F,TT OR CAML F,TT
MOVE F,TT
JRST PLUS4
.GREAT: EXCH A,B
.LESS: PUSH P,A
PUSH P,B
MOVNI T,2
LESSP: SKIPA A,[CAML F,2]
GREATERP:
HRLZI A,(CAMG F,)
MOVEI D,GRESS
MNMX1: HRLI D,(JRST)
MOVEM D,PLUS3
MOVNM T,PLUS8
MOVE R,T
AOJGE T,MNMX9
HRRI A,TT
MOVEM A,GRESS0 ;THIS IS ALSO MNMX0
ADD R,P
MOVE A,1(R)
SETOM PLUS0
JSP T,FLTSKP
SETZM PLUS0
MOVE F,TT
AOJA R,PLUS7
MNMX9: MOVEI D,QMAX+1(A)
SOJA T,WNALOSS
GRESS: XCT GRESS0
JRST GRUSE
MOVE F,TT
CAME P,R
JRST PLUS9
SUB P,PLUS8
JRST TRUE
GRUSE: SUB P,PLUS8
JRST FALSE
.DIF: PUSH P,A
PUSH P,B
MOVNI T,2
DIFFERENCE: MOVE R,[JRST DIF2]
MOVE D,R
SOJA D,DIF1
SKIPA D,[FSBR F,TT]
DIF2: MOVE D,[SUB F,TT]
MOVEM D,PLUS3
MOVE D,[FSBR F,TT]
MOVEM D,PLUS6
MOVE F,TT
JRST PLUS4
.QUO: PUSH P,A
PUSH P,B
MOVNI T,2
QUOTIENT: MOVE R,[JRST QUO2]
MOVE D,R
SOJA D,QUO1
SKIPA D,[FDVR F,TT]
QUO2: MOVE D,[JRST QUO3]
MOVEM D,PLUS3
MOVE D,[FDVR F,TT]
MOVEM D,PLUS6
MOVE F,TT
JRST PLUS4
QUO3: IDIVM F,TT
EXCH F,TT ;ALL THIS LOSSAGE SO THAT F+1 WONT BE DISTURBED
JFCL 8.,.+2
JRST PLUS4
SKIPN RWG
JRST OVFLER
SKIPGE TT
SOSA F,TT
AOS F,TT
JFCL 8.,OVFLER
JRST PLUS4
.TIMES: PUSH P,A
PUSH P,B
MOVNI T,2
TIMES: MOVE R,[IMUL F,TT]
MOVE D,[FMPR F,TT]
QUO1: MOVEI F,1
JRST PLUS1
.PLUS: PUSH P,A
PUSH P,B
MOVNI T,2
PLUS: MOVE R,[ADD F,TT]
MOVE D,[FADR F,TT]
DIF1: MOVEI F,0
PLUS1: MOVNM T,PLUS8
JUMPE T,PLUS2
ADD T,P
MOVEM R,PLUS3
SETZM PLUS0
MOVE R,T
PLUS7: MOVEM D,PLUS6
HRLS PLUS8
JRST 2,@[PLUS4]
PLUS5: MOVE D,PLUS6 ;FAD F,TT OR FMP F,TT OR ETC.
MOVEM D,PLUS3
SETOM PLUS0
EXCH F,TT
JSP T,IFLOAT
EXCH F,TT
PLUS3A: XCT PLUS3
PLUS4: CAMN P,R
JRST PLUS2
PLUS9: MOVE A,1(R)
JSP T,FLTSKP
JRST .+4
SKIPE PLUS0
AOJA R,PLUS3A
AOJA R,PLUS5
SKIPE PLUS0
JSP T,IFLOAT
AOJA R,PLUS3A
PLUS2: MOVE TT,F
JFCL 8.,PLUS2V
PLUS2A: SUB P,PLUS8 ;FALL THRU TO MAKNUM
SKIPN PLUS0
JRST FIX1
JRST FLOAT1
PLUS2V: JSP T,T7O0
JRST PLUS2A
] ;END OF ARITH OPS WITH BIGNUM=0
T7O0: SKIPE VZUNDERFLOW ;NON-NIL => FLOATING UNDERFLOW
TLNN T,100 ; YIELDS ZERO RESULT INSTEAD OF ERROR
JRST UNOVER
MOVEI TT,0
JRST (T)
SUBTTL GENERAL EXPONENTIATION ROUTINE
EXPT: JRST 2,@[.+1] ;SUBR 2 - COMPUTE A↑B
EXCH A,B ;FIND TYPE OF EXPONENT FIRST
IFN BIGNUM,[
JSP T,NVSKIP ;EXPONENT IS . . .
JRST XPT.B ;IT'S A BIGNUM
JRST XPT.X ;IT'S A FIXNUM
EXCH A,B ;IT'S A FLONUM
JSP T,NVSKIP ;BASE IS . . .
JRST XPTBL ;BIGNUM BASE
JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT
] ;END OF IFN BIGNUM
IFE BIGNUM,[
JSP T,FLTSKP ;EXPONENT IS . . .
JRST XPT.X ;IT'S A FIXNUM
EXCH A,B ;IT'S A FLONUM
JSP T,FLTSKP ;BASE IS . . .
JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT
] ;END OF IFE BIGNUM
;;; ;FLONUM↑FLONUM
XPTLL: SKIPN (B) ; X↑0.0 => 1.0
JRST 1.0PJ
JUMPE TT,CPOPJ ; 0.0↑X => 0.0
PUSH FLP,TT
MOVEI A,(FLP)
PUSHJ P,LOG.. ;SO COMPUTE FLONUM↑FLONUM BY
FMPR TT,(B) ; USING THE FORMULA:
MOVEM TT,(FLP)
MOVEI A,(FLP) ; B (B LOG A)
PUSHJ P,EXP.. ; A = E
SUB FLP,R70+1
JRST FLOAT1
XPT.X: EXCH A,B ;FIXNUM EXPONENT FOUND
MOVE D,TT
BG$ JSP T,NVSKIP ;CHECK BASE FOR FIXNUM EXPONENET
BG$ JRST XPTBX ;BIGNUM BASE
BG% JSP T,FLTSKP
JRST XPTXX0 ;FIXNUM BASE
PUSH P,CFLOAT1 ;FLONUM BASE => FLONUM RESULT
XPTLX: JSP R,XPTZL ;CHECK EASY CASES
SKIPA R,TT ;NORMAL CASE - USE THE MULTIPLY
XPTLX1: FMPR R,R ; AND SQUARE HACK
TRNE D,1
FMPR T,R
JFCL 8,XPTOV ;CHECK FOR OVERFLOW
LSH D,-1
JUMPN D,XPTLX1
XPTLX2: MOVE TT,T ;ANSWER GOES IN TT
POPJ P,
XPTOV: JSP T,T7O0
POPJ P,
XPTXX0: PUSHJ P,XPTXX
JRST FIX1
POPJ P,
;;; SKIPS IF ANSWER IS A BIGNUM
XPTXX: JSP R,XPTZX ;FIXNUM↑FIXNUM - CHECK EASY CASES
JUMPL D,ZPOPJ
IFE BIGNUM,[
SKIPA R,TT
XPTXX5: IMUL R,R
TRNE D,1
IMUL T,R
LSH D,-1
JUMPN D,XPTXX5
MOVE TT,T
JFCL 8,XPTOV
POPJ P,
] ;END OF IFE BIGNUM
IFN BIGNUM,[
SKIPGE R,TT
JRST XPTXX3
JFFO R,.+1
LSH R,1(F)
JUMPE R,2XPT ;XPTZX HAS CHECKED BASE, SO IT'S NOT 0/1/-1
MOVE R,TT
XPTXX3: MOVE TT,T ;HERE YOU GO FANS, YOU BASIC MULTIPLY BY SQUARING LOOP.
MOVEM D,NORMF
TRNE D,1
IMUL T,R
JFCL 8.,EXPT6C
LSH D,-1
JUMPN D,XPTXX4
MOVE TT,T
POPJ P,
XPTXX4: MOVE F,R
IMUL R,R
JFCL 8.,EXPT6B
JRST XPTXX3
2XPT: MOVNI F,(F)
IMULI D,36.-1(F)
MOVEI TT,1
CAIL D,35.
JRST 2BGXPT
ASH TT,(D)
POPJ P,
2BGXPT: IDIVI D,35.
ASH TT,(R)
JSP T,FIX1A
PUSHJ P,NCONS
2BGXP1: MOVE B,CIN0
PUSHJ P,XCONS
SOJG D,2BGXP1
PUSHJ P,BGNMAK
JRST POPJ1
] ;END OF IFN BIGNUM
IFN BIGNUM,[
XPTBL: PUSH P,A ;BIGNUM↑FLONUM
PUSHJ P,FLBIG ;SO FLOAT THE BIGNUM, THEN USE
SUB P,R70+1 ; FLONUM↑FLONUM
JRST XPTLL
XPT.B: EXCH A,B ;BIGNUM FOUND AS EXPONENT
HLRZ D,(TT)
HRRZ D,(D)
TLNE TT,400000
TLO D,400000 ;D GETS SIGN-BIT IN 4.9, RANDOM-NON-ZERO-BIT IN 3.1
TLO D,1 ;AND ODDP-BIT IN 1.1
JSP T,NVSKIP
JRST OVFLER
JRST XPTZX0
PUSH P,CFLOAT1
JSP R,XPTZL ;FLONUM↑BIGNUM -- CHECK EASY CASES
MOVMS TT
CAML TT,T ;T SUPPOSED TO HAVE 1.0
JRST OVFLER
SKIPN VZUNDERFLOW
JRST UNFLER
JRST ZPOPJ ;PUTS A RANDOM ZERO IN TT, AND POPJS
XPTZX0: PUSH P,CFIX1
JSP R,XPTZX ;FIXNUM↑BIGNUM -- CHECK EASY CASES
JUMPL D,ZPOPJ ;N↑-<M> ==> 0
JRST OVFLER
;;; MUST SKIP 1 AS POPJ SINCE ONLY COME HERE FROM XPTXX
EXPT6B: MOVE R,F ;RESTORE R, AND LEAVE OLD D IN NORMF
EXPT6C: PUSHJ FXP,SAV5 ;EXPECTS RUNNING SQUARER IN R, ACCUMULATION IN TT
PUSHJ P,BNCV ;NOTE THAT D CANT BE ZERO WHEN WE COME HERE
MOVE B,A ;ACCUMULATION AS BIGNUM IN B
MOVE TT,R
PUSHJ P,BNCVTM
MOVE A,TT ;RUNNING SQUARER IN A
EXPT1A: MOVEM A,-4(P)
MOVE D,NORMF
EXPT1: TRNN D,1 ;-4(P) AND A HAVE RUNNING SQUARER, B HAS ACCUMULATION
JRST EXPT2
MOVEM D,NORMF
PUSHJ P,BNMUL
MOVE D,NORMF
EXCH A,-4(P)
EXPT3: LSH D,-1 ;-4(P) NOW HAS ACCUMULATION, A HAS RUNNING SQUARER
JUMPE D,EXPT4
MOVE B,A
MOVEM D,NORMF
PUSHJ P,BNMUL
MOVE B,-4(P)
JRST EXPT1A
EXPT2: MOVEM B,-4(P)
JRST EXPT3
EXPT4: JSP R,RSTR5
PUSHJ P,BNCONS
JRST POPJ1
XPTBX: SOJLE D,XPTBX1 ;BIGNUM↑FIXNUM
AOJG D,CPOPJ ; X↑1 => X
MOVEI A,IN0
JUMPL D,CPOPJ ; X↑-N => 0
AOJA A,CPOPJ ; X↑0 => 1
XPTBX1: MOVE A,TT
PUSHJ FXP,SAV5
MOVEI B,BN.1 ;1, STORED AS A BIGNUM
AOJA D,EXPT1 ;RESTORE VALUE OF D
] ;END OF IFN BIGNUM
XPTII: PUSH P,CFIX1 ;SUBR 2 NCALLABLE (REAL NAME: ↑)
JSP T,FXNV1
JSP T,FXNV2
JRST 2,@[.+1]
PUSHJ P,XPTXX
POPJ P,
LERR [SIXBIT \ANSWER TOO BIG - ↑!\]
XPTI$: PUSH P,CFLOAT1 ;SUBR 2, NCALLABLE (REAL NAME: ↑$)
JSP T,FLNV1
JSP T,FXNV2
JRST 2,@[XPTLX] ;OVERFLOW MUST BE CLEAR ON ENTRY TO XPTLX
XPTZL: JUMPN TT,XPTZL1 ;FLONUM BASE (CFLOAT1 ON PDL)
SKIPN D ; 0.0↑X => 0.0,
1.0PJ: MOVSI TT,(1.0) ; EXCEPT 0.0↑0.0 => 1.0
POPJ P,
XPTZL1: JUMPGE D,XPTZL2 ; -Y 1 Y
MOVSI T,(1.0) ; X = (---)
FDVR T,TT ; X
MOVE TT,T
MOVMS D
XPTZL2: CAMN TT,[-1.0]
JRST XPTM1 ;BASE IS -1.0
CAMN TT,[1.0]
POPJ P, ;BASE IS 1.0
MOVSI T,(1.0) ;T GETS 1.0 IN ANY CASE
JRST (R)
XPTZX: JUMPN TT,XPTZX1 ;FIXNUM BASE - PDL HAS CFIX1
JUMPN D,CPOPJ ; 0↑X => 0,
AOJA TT,CPOPJ ; EXCEPT 0↑0 => 1
XPTZX1: CAMN TT,XC-1 ;BASE = -1
JRST XPTM1
CAIN TT,1 ;FOR BASE = 1, ALSO EASY
POPJ P,
MOVEI T,1 ;T GETS 1 IN ANY CASE
JRST (R)
XPTM1: TRNN D,1 ;FOR BASE = -1 OR -1.0, SIMPLY
MOVMS TT ; ASCERTAIN PARITY OF EXPONENT
POPJ P,
SUBTTL RANDOM, HAULONG FUNCTIONS
RANDOM: SKIPA F,CFIX1
MOVEI F,CPOPJ
AOJG T,RNDM0
AOJL T,RAND9
POP P,A
JUMPE T,RAND4 ;FOR THE NONCE, WE ALLOW 2 ARGS TO INITIALIZE
JUMPE A,IRAND ;ONE ARG OF NIL CAUSES INITIALIZATION
PUSH P,F
JSP F,RNDM0
MOVE D,TT
JSP T,FXNV1
JUMPLE TT,RAND1
LSH D,-1
IDIV D,TT
SKIPA TT,R
RAND1: SETZ TT,
POPJ P,
RAND4: SUB P,R70+1
IRAND: MOVNI T,70. ;INITIALIZE THE RANDOMNESS
MOVE TT,[171622221402]
IRAND0: MOVE D,TT
MULI D,3125.
DIV D,[377777777741]
MOVEM R,TT
LSH R,1
MOVEM R,RBLOCK+70.(T)
AOJLE T,IRAND0
MOVEI D,36.
MOVEM D,RNOWS
RNDM1: MOVEI T,70.
MOVEM T,RBACK
JRST RNDM1A
RNDM2: MOVEI D,70.
MOVEM D,RNOWS
JRST RNDM2A
RNDM0: SOSGE T,RBACK ;BASIC COMBINATION FOR RANDOMNESS
JRST RNDM1
RNDM1A: SOSGE D,RNOWS
JRST RNDM2
RNDM2A: MOVE TT,RBLOCK(T)
ADDB TT,RBLOCK(D)
JRST (F)
SUBTTL HAULONG FUNCTION
HAULONG: PUSH P,CFIX1
.HAU:
BG$ JSP T,NVSKIP
BG$ JRST 1HAU
BG% JSP T,FLTSKP
JRST 4HAU
%WTA FXNMER
JRST .HAU
4HAU: MOVM D,TT
MOVEI TT,35.+1
3HAU1: JFFO D,.+2
TDZA TT,TT
SUBI TT,(R)
POPJ P,
IFN BIGNUM,[
1HAU: MOVEI F,(TT) ;RECEIVES BN HEADER IN TT
HRRZ R,(F) ;LEAVES HAULONG IN TT, PTR TO NEXT TO LAST
MOVEI TT,35.+1 ;IN F, CNT OF # OF ZEROS FOR LAST WD IN R
JUMPE R,3HAU
2HAU: ADDI TT,35.
HRRZ D,(R)
JUMPE D,3HAU
MOVEI F,(R)
MOVEI R,(D)
JRST 2HAU
3HAU: HLRZ T,(R)
MOVE D,(T)
JRST 3HAU1
] ;END OF IFN BIGNUM
SUBTTL HAIPART FUNCTION
HAIPART:
IFN BIGNUM,[
JSP T,NVSKIP
JRST 1HAI
]
IFE BIGNUM, JSP T,FLTSKP
JRST 0HAI
%WTA FXNMER
JRST HAIPART
0HAI: MOVM TT,TT
JFFO TT,.+2
JRST 0POPJ ;FOR ZERO ARG, JUST RETURN ARG!
HRREI F,-36.(D) ;-<# OF BITS IN ARG> NO IN AC F
JSP T,FXNV2
JUMPLE D,0HAI1
ADD D,F
JUMPG D,PDLNKJ ;MORE DIGITS REQUESTED THAN ARE AVAILABLE
LSH TT,(D) ;GETTING HAI PART INTO AC TT
JUMPGE TT,FIX1
IFN BIGNUM, JRST ABSOV
IFE BIGNUM, JRST OVFLER
0HAI1: JUMPE D,0POPJ ;RETURNS A FIXNUM ZERO
CAMG D,F
JRST 0HAI3
MOVNS D
0HAI2: SETO F, ;REQUESTING LOW PART BY NEG COUNT
LSH F,(D) ;CREATE MASK TO LET PROPER BITS THRU
ANDCM TT,F
JRST FIX1
0HAI3: JUMPGE TT,PDLNKJ
IFN BIGNUM, JRST ABSOV
IFE BIGNUM, JRST OVFLER
IFN BIGNUM*USELESS,[
3HAI: MOVNS D ;ACTUALLY ASKING FOR LOW PART
CAILE D,35.
JRST 3HAI1
JUMPE D,0POPJ
HLRZ TT,(TT)
MOVE TT,(TT)
JRST 0HAI2
3HAI1: PUSH FXP,D
PUSHJ P,1HAU
POP FXP,D
CAIL D,(TT)
JRST PDLNKJ
IDIVI D,35.
PUSH P,C
MOVEI F,C ;F WILL BE POINTER TO LAST OF FORMNG LIST
MOVE C,(A) ;C HOLDS POINTER TO FNAL RESULT
MOVEI B,(C) ;B GOES CDR'ING DOW INPUT ARG
3HAI2: HLRZ TT,(B)
MOVE TT,(TT)
PUSHJ P,C1CONS
HRRM A,(F)
MOVEI F,(A)
HRRZ B,(B)
SOJG D,3HAI2 ;D HOLDS HOW MANY WORDS TO USE
JUMPE R,3HAI3 ;R HOLDS HOW MANY LEFT OVER BITS FROM D WORDS
HLRZ TT,(B)
MOVE TT,(TT)
MOVNI D,1
LSH D,(R)
ANDCM TT,D
JUMPE TT,3HAI3
PUSHJ P,C1CONS
HRRM A,(F)
3HAI3: MOVEI A,(C)
PUSH P,AR1
PUSHJ P,BNTRUN ;IN LOPART CASE, MAY NEED TO GET
POP P,AR1 ; RID OF LEADING ZEROS
POP P,C
HRRZ B,(A) ;MAYBE WHAT WE HAVE IS SHORT ENOUGH
JUMPN B,BGNMAK ; TO FIT IN A FIXNUM; IF SO, WE CAN
JRST CAR ; USE ONE WE JUST CONSED FOR BIGNUM!
] ;END OF IFN BIGNUM*USELESS
SUBTTL LENGTH AND BIGP FUNCTIONS
LNGTER: WTA [NON-LIST - LENGTH!]
JRST LNGTH0
LENGTH: SKIPA T,CFIX1
MOVEI T,CPOPJ
LNGTH0:
SKOTT A,LS
JUMPN A,LNGTER
LNG1A: TDZA TT,TT .SEE $LISTEN ;SAVES R
LNGTH1: HRRZ A,(A)
JUMPE A,(T)
AOJA TT,LNGTH1
IFE BIGNUM, BIGP==FALSE
IFN BIGNUM,[
BIGP: PUSHJ P,TYPEP ;SUBR 1 - IS IT A BIGNUM?
CAIE A,QBIGNUM
SETZ A, ;RETURNS T OR NIL
JRST NOTNOT
] ;END OF IFN BIGNUM
SUBTTL BOOLE AND ODDP FUNCTIONS
BOOLE: SKIPA F,CFIX1
MOVEI F,CPOPJ
MOVE R,T
ADDI R,2(P)
HRLI T,-1(T)
MOVEM T,PLUS8
MOVE A,-1(R)
JSP T,FXNV1
DPB TT,[350400,,BOOLI]
PUSHJ P,BOOLG
MOVE D,TT
BOOLL: PUSHJ P,BOOLG
XCT BOOLI
JRST BOOLL
BOOLG: CAIL R,(P)
JRST BOOL1
MOVE A,(R)
JSP T,FXNV1
AOJA R,CPOPJ
BOOL1: ADD P,PLUS8
POP P,B
JRST (F)
ODDP1: %WTA FXNMER
ODDP: SKOTT A,FX
IFN BIGNUM, JRST ODDP4
IFE BIGNUM, JRST ODDP1
ODDP2:
MOVE TT,(A)
ODDP21: TRNN TT,1
JRST FALSE
JRST TRUE
IFN BIGNUM,[
ODDP4: TLNN TT,BN
JRST ODDP1
MOVE TT,(A)
ODDP3: HLRZ TT,(TT)
MOVE TT,(TT)
JRST ODDP21
] ;END OF IFN BIGNUM
SUBTTL FSC, ROT, LSH, AND GCD FUNCTIONS
$FSC: JSP T,FLTSKP ;SUBR 2
JFCL
JSP T,FXNV2
CAIG D,-1
FSC TT,(D)
JRST FLOAT1
$ROT: SKIPA R,[ROT TT,(D)] ;SUBR 2
$LSH: HRLZI R,(LSH TT,(D)) ;SUBR 2
PUSH P,CFIX1
SHIFTY: JSP T,FLTSKP
JFCL
JSP T,FXNV2
XCT R
POPJ P,
IFN USELESS,[
IFE BIGNUM, GCD:
.GCD: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE
JSP T,FXNV1 ;GCD OF FIXNUM ARGS ONLY
JSP T,FXNV2
MOVM TT,TT ;GCD(-X,Y) = GCD(X,Y)
MOVM D,D ;GCD(X,-Y) = GCD(X,Y)
.GCD0: JUMPE TT,.GCD2 ;GCD(0,Y) = ABS(Y)
JUMPE D,CPOPJ ;GCD(X,0) = ABS(X)
CAMGE D,TT
EXCH D,TT
JRST .GCD1
.GCD3: MOVE D,TT
MOVE TT,R
.GCD1: IDIV D,TT ;GOOD OLD EUCLIDEAN ALGORITHM
JUMPN R,.GCD3
POPJ P,
.GCD2: MOVE TT,D
POPJ P,
IFN BIGNUM,[
GCD0: %WTA FXNMER ;NON-FIXNUM VALUE
GCD: SETZ R, ;SUBR 2 - GCD, EVEN OF BIGNUM ARGS
JSP T,NVSKIP
TRO R,1 ;TURN ON BIT IF BIGNUM
JRST .+2 ;FIXNUMS ARE OK TOO
JRST GCD0 ;DON'T LIKE FLONUMS
EXCH A,B
MOVE D,TT
JSP T,NVSKIP ;NOW CHECK OTHER ARG
TRO R,2
JRST .+2
JRST GCD0 ;I TOLD YOU, I DON'T LIKE FLONUMS!
JRST .+1(R) ;SO FIGURE OUT THIS MESS
JRST GCDXX ;FIXNUM AND FIXNUM
EXCH A,B ;FIXNUM AND BIGNUM
JRST GCDBX ;BIGNUM AND FIXNUM
JRST GCDBG ;BIGNUM AND BIGNUM
GCDXX: MOVM TT,TT ;GCD OF TWO FIXNUMS
JUMPL TT,GCDOV1 ;CHECK OUT -400000000000 CASES
MOVM D,D
JUMPL D,GCDOV
PUSH P,CFIX1 ;EVERYTHING OKAY - CAN USE .GCD0
JRST .GCD0
] ;END OF IFN BIGNUM
] ;END OF IFN USELESS
SUBTTL FUNCTIONS: = < > 1+ 1+$ 1- 1-$
$EQUAL: JSP T,FLTSKP ;NUMERIC EQUAL =
JRST IEQUAL
EXCH A,B
MOVE D,TT
$EQL1: JSP T,FLTSKP
JRST 2EQNF
$IEQ: CAME D,TT
JRST FALSE
JRST TRUE
IEQUAL: EXCH A,B
MOVE D,TT
JSP T,FLTSKP
JRST $IEQ
JRST 1EQNF
$LESS: EXCH A,B
$GREAT: JSP T,FLTSKP ;NUMERIC GREATERP AND LESSP <,>
JRST IGRT
MOVE D,TT
EXCH A,B
$IGL1: JSP T,FLTSKP
JRST 2GPNF
$IGL: CAMG D,TT
JRST FALSE
JRST TRUE
IGRT: MOVE D,TT
MOVE A,B
JSP T,FLTSKP
JRST $IGL
JRST 1GPNF
IADD1: JSP T,FLTSKP ;FIXNUM ADD1 1+
AOJA TT,FIX1
%WTA IARERR
JRST IADD1
%WTA $ARERR
$ADD1: JSP T,FLTSKP ;FLONUM ADD1 1+$
JRST $ADD1-1
FADRI TT,(1.0)
JRST FLOAT1
ISUB1: JSP T,FLTSKP ;FIXNUM SUB1 1-
SOJA TT,FIX1
%WTA IARERR
JRST ISUB1
%WTA $ARERR
$SUB1: JSP T,FLTSKP ;FLONUM SUB1 1-$
JRST $SUB1-1
FSBRI TT,(1.0)
JRST FLOAT1
SUBTTL FUNCTIONS: + +$ - -$ * *$ // //$
$ARITH: SETOM PLUS0
SKIPA
IARITH: SETZM PLUS0 ;SET UP FOR FIXNUM ARITHMETIC
AOJGE T,ARIT0
I$B: JRST 2,@[.+1]
SKIPA B,T
I$ART2: XCT R
POP P,A ;MAIN LOOP FOR FIXNUM AND FLONUM ARITHMETIC
ARITH: JSP T,FLTSKP ;MAKE SURE NO MIXED MODES, RETURN MACHINE NUMBER IN TT
TDZA T,T
MOVNI T,1
CAME T,PLUS0
JRST ARTHER
AOJLE B,I$ART2
CAIN B,69.+1 ;SIGNAL FOR CASE WITH ONE ARG
EXCH TT,D
XCT F
JFCL 8.,ARIT1
IARDS: SKIPE PLUS0 ;DISPATCH TO CONS UP FINAL ANSWER
JRST FLOAT1
JRST FIX1
ARIT1: JSP T,T7O0
JRST IARDS
ARIT0: MOVE TT,D
JUMPN T,IARDS
MOVEI T,69.
JRST I$B
IDIFFERENCE:
SKIPA F,[SUB TT,D] ;-
IPLUS: MOVE F,[ADD TT,D] ;+
MOVE R,[ADD D,TT]
MOVEI D,0
JRST IARITH
IQUOTIENT:
SKIPA F,[IDIV TT,D] ;/
ITIMES: MOVE F,[IMUL TT,D] ;*
MOVE R,[IMUL D,TT]
MOVEI D,1
JRST IARITH
$DIFFERENCE:
SKIPA F,[FSBR TT,D] ;-$
$PLUS: MOVE F,[FADR TT,D] ;+$
MOVE R,[FADR D,TT]
MOVEI D,0
JRST $ARITH
$QUOTIENT:
SKIPA F,[FDVR TT,D] ;/$
$TIMES: MOVE F,[FMPR TT,D] ;*$
MOVE R,[FMPR D,TT]
MOVSI D,(1.0)
JRST $ARITH
IARZAR: MOVE TT,D
JRST FIX1
IRP TP,,[I,$]
IRP FUN,,[PLUS,DIFFERENCE,QUOTIENT,TIMES]
.!TP!!FUN: JSP TT,ARICOM
TP!!FUN
TERMIN
TERMIN
ARICOM: PUSH P,A
PUSH P,B
MOVNI T,2
JRST @(TT)
;;; ********** NUMBER SUBRS FOR LISP **********
SUBTTL SIN AND COS FUNCTIONS
SIN: PUSH P,CFLOAT1
SIN.: JSP T,FLTSKP
JSP T,IFLOAT
MOVM T,TT ;SIN(-X)=-SIN(X)
CAMLE T,C1.0E5 ;ARG SHOULD BE <= 1.0E5 (ELSE RESULT
JRST SIN.ER ; WOULD BE GROSSLY INACCURATE)
CAMG T,[.001] ;THE RELATIVE ERROR OF APPROXIMATION [BY THIS RATIONAL
; ; FUNCTION] IS BOUNDED BY ABOUT 2.0E-7, BUT OCCASIONALLY
; ; COMES CLOSE TO THIS. SINCE THE ERROR OF TRUNCATION
; ; INHERENT IN TAKING X-(1/6)*X**3 FOR THE TAYLOR SERIES
; ; OF SIN(X) IS MUCH LESS THAN 2.0E-7, IT WILL BE SUFFICIENT
; ; TO TAKE X FOR SIN(X) WHENEVER THE RELATIVE ERROR TERM
; ; [(1/6)*X**3] IS LESS THAN 2.0E-7. SOLVING, WE FIND
JRST SIN.XT ; X=.001 WILL DO.
EXCH T,TT
SIN.0: FDVR TT,PI%2 ;DIVIDE ARG BY PI/2 (ARG IS NOW IN QUADRANTS)
MULI TT,400 ;TT GETS CHARACTERISTIC, R GETS MANTISSA
SETZB R,F
ASHC D,-243(TT) ;D GETS INTEGER PART, R GETS FRACTION (OF ARG)
ASHC R,-8. ;R GETS HIGH 27. BITS OF FRACTION, F GETS REST
TLO R,200000 ;FLOAT R
LSH F,-8.
TLO F,145000 ;FLOAT F (NOTE: 145=200-33; R,F NOW FORM 2-WORD FLOATING NUMBER)
FADR R,F ;ADD F TO R (THIS WHOLE MESS PRESERVES PRECISION AND NORMALIZES)
TRCN D,3 ;R IS NOW A QUADRANT 1 ANGLE - WHAT WAS ORIGINAL QUADRANT?
JRST SIN.1 ;QUADRANT 1 - ALL IS WELL
TRCE D,3
MOVN T,T ;QUADRANT 2 OR 3 - MUST REVERSE SIGN: SIN(X)=-SIN(X-PI)
TRNE D,1
FSBR R,FPWUN ;QUADRANT 2 OR 4 - SUBTRACT 1 TO PUT IN RANGE -1.0 TO 0
SIN.1: SKIPGE T ;TEST SINE SIGN FLAG
MOVN R,R ;IF NEGATIVE, RESULT MUST BE NEGATIVE
MOVE D,R
FMPR D,D ;D <- R*R IS ALWAYS NON-NEGATIVE
MOVE TT,SIN.CF+4 ;MOBY APPROXIMATION
MOVEI T,3
SIN.2: FMPR TT,D
FADR TT,SIN.CF(T)
SOJGE T,SIN.2
FMPR TT,R
SIN.XT: POPJ P, ;RETURN - RESULT IS IN TT
PI%2: 1.570796326 ;A PIECE OF PI (ABOUT 50%)
SIN.CF: 1.5707963185 ;COEFFICIENTS FOR SIN APPROXIMATION
-0.6459637111
0.07968967928
-0.00467376557
0.00015148419
COS: PUSH P,CFLOAT1
COS.: JSP T,FLTSKP
JSP T,IFLOAT
SKIPLE T,TT
MOVN T,TT
FADR T,PI%2 ;PI/2-X IN T, SINCE COS(X) = SIN(PI/2-X)
MOVM TT,T ;|PI/2-X| IN TT
CAMLE TT,C1.0E5
JRST COS.ER
JRST SIN.0
SUBTTL SQRT FUNCTION
SQRT: PUSH P,CFLOAT1
SQRT.: JSP T,FLNV1
JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR
SQRT..: MOVE D,TT ;D GETS ARG
LDB T,[341000,,TT] ;FOR FIRST APPROXIMATION, TRY
ADDI T,100 ; HALVING CHARACTERISTIC OF ARGUMENT,
DPB T,[331100,,TT] ; AND USE SAME MANTISSA
MOVEI T,5 ;NOW DO MOBY ITERATION
SQRT.1: MOVE R,TT ; R <- TT
MOVE TT,D
FDVR TT,R ; R + D/R
FADR TT,R ; TT <- ---------
FSC TT,-1 ; 2
SOJN T,SQRT.1
POPJ P,
SUBTTL LOG FUNCTION
LOG: PUSH P,CFLOAT1
LOG.: PUSHJ P,NUMFLT
LOG..: JUMPLE TT,LOG.ER ;NON-POSITIVE ARG IS AN ERROR
MULI TT,400
HRREI TT,-201(TT) ;SAVE CHARACTERISTIC IN TT
LSH D,-8. ;REDUCE ARG TO VALUE X BETWEEN 1.0 AND 2.0
TLO D,201000
MOVEI R,0
CAMN D,FPWUN ;LOG(1.0)=0.0 (ALSO FOR WHOLE POWERS OF 2 THIS SAVES TIME)
JRST LOG.2
MOVE T,D ; X - SQRT(2)
FSBR T,ROOT2 ; T <- -------------
FADR D,ROOT2 ; X + SQRT(2)
FDVRB T,D
FMPR D,D ; D <- T*T
MOVEI F,3 ;MOBY APPROXIMATION TO LOG BASE 2
LOG.1: FMPR R,D
FADR R,LOG.CF(F)
SOJGE F,LOG.1
FMPR R,T
FADR R,[0.5]
LOG.2: JSP T,IFLOAT ;FLOAT CHARACTERISTIC
FADR TT,R ;ADD TO LOG OF MANTISSA
FMPR TT,[0.6931471806] ;MULTIPLY BY LN 2 TO GET LOG BASE E
POPJ P,
ROOT2: 1.4142135625 ;SQRT(2)
LOG.CF: 2.885390073 ;COEFFICIENTS FOR LOG APPROXIMATION
0.9618007623
0.5765843421
0.4342597513
NUMFLT:
IFE BIGNUM, JSP T,FLTSKP
IFN BIGNUM, JSP T,NVSKIP
IFN BIGNUM, JRST NUMFL3
JSP T,IFLOAT
POPJ P,
IFN BIGNUM,[
NUMFL3: PUSH P,A
PUSHJ P,FLBIG
JRST POPAJ
] ;END OF IFN BIGNUM
SUBTTL ATAN FUNCTION
ATAN: PUSH P,CFLOAT1
ATAN.: EXCH A,B
PUSHJ P,NUMFLT
PUSH FXP,TT
MOVEI A,(B)
PUSHJ P,NUMFLT
POP FXP,D
MOVM R,TT ;GET ABSOLUTE VALUE OF Y
MOVM F,D ;GET ABSOLUTE VALUE OF X
MOVEM R,ATAN.Y ;SAVE ABS(Y)
MOVEM F,ATAN.X ;SAVE ABS(X)
HLR D,TT ;D HAS <LEFT HALF OF X>,,<LEFT HALF OF Y>
MOVEM D,ATAN.S ;SAVE THAT MESS (HAS SIGNS OF X AND Y)
MOVE T,R
JFCL 8,.+1
FSBR T,F ; ABS(Y)-ABS(X)
FADR R,F ; T <- -----------------
FDVRB T,R ; ABS(Y)+ABS(X)
FMPR R,R ; R <- T*T
MOVE D,ATAN.C+7 ;MOBY APPROXIMATION
MOVEI F,6
ATAN.1: FMPR D,R
FADR D,ATAN.C(F)
SOJGE F,ATAN.1
FMPR D,T
MOVM TT,D
CAMGE TT,[.7855]
CAMGE TT,[.7853]
JRST ATAN.3
JUMPGE D,ATAN.2 ;PATCH UP FOR WHEN RATIONAL APPROXIMATION NOT VERY GOOD
MOVE D,ATAN.Y ;WE CAN USE Y/X FOR ATAN (Y/X)
FDVR D,ATAN.X
JRST ATAN.4
ATAN.2: MOVN D,ATAN.X
FDVR D,ATAN.Y
FADR D,PI%2
JRST ATAN.4
ATAN.3: FADR D,[0.7853981634] ;PI/4
ATAN.4: MOVN TT,D ;NOW WE HAVE A QUADRANT 1 RESULT (CALL IT Q)
FADR TT,PI% ;PATCH-UP STUFF TO GET RIGHT QUADRANT
SKIPL F,ATAN.S ; X>0 I X<0
EXCH D,TT ;-------------------------I-------------------------
FSC D,1 ; D <- PI-Q I D <- Q
TRNE F,400000 ; TT <- Q I TT <- PI-Q
FADR TT,D ; Y>0 I Y<0 I Y>0 I Y<0
JFCL 8,ATAN.7 ;------------I------------I------------I------------
POPJ P, ; TT<-Q I TT<-2*PI-Q I TT<-PI-Q I TT<-PI+Q
PI%: 3.1415926536 ;A WELL-KNOWN NUMBER
ATAN.C: 0.9999993329 ;COEFFICIENTS FOR ATAN APPROXIMATION
-0.3332985605
0.1994653599
-0.139085335
0.0964200441
-0.0559098861
0.0218612288
-0.004054058
SUBTTL EXP FUNCTION
EXP: PUSH P,CFLOAT1
EXP.: JSP T,FLTSKP
JSP T,IFLOAT
EXP..: SETZ R,
MOVEM TT,EXP.S ;SAVE SIGN OF ARG ON PDL
MOVM TT,TT ;GET ABSOLUTE VALUE OF ARG
FMPR TT,[0.4342944819] ;LOG BASE 10. OF E ;FROM NOW ON WE DO 10.↑X, NOT E↑X
MOVE F,FPWUN ;F HOLDS 10.↑<INTEGER PART OF ARG>
CAMG TT,FPWUN ;IF ARG <=1.0 GO DO RATIONAL APPROXIMATION
JRST EXP.RX
MULI TT,400
ASHC D,-243(TT) ;D GETS INTEGER PART OF ARG
CAIG D,43 ;CHECK MAGNITUDE OF ARG
JRST EXP.1
SKIPGE TT,EXP.S ;TOO LARGE - RESULT CAN'T BE REPRESENTED
TDZA TT,TT
JRST EXP.ER
POPJ P, ;NEGATIVE ARG PRODUCES ZERO (UNDERFLOW)
EXP.1: CAIG D,7 ;SKIP IF INTEGER PART OF ARG > 7
JRST EXP.2
LDB T,[030300,,D] ;GET TOP 3 BITS OF 6 BIT INTEGER PART
ANDI D,7 ;AND THEM OUT OF D
MOVE F,INTLG(T) ;F GETS (10.↑T)↑8. = 10.↑(T*8.)
FMPR F,F
FMPR F,F
FMPR F,F
EXP.2: FMPR F,INTLG(D) ;MULTIPLY F BY APPROPRIATE 10.↑D (0<=D<=7)
LDB TT,[103300,,R] ;NOW GET FRACTION PART OF ARG
TLO TT,177000 ;THIS STRANGENESS FLOATS
FADR TT,TT ; AND NORMALIZES THE FRACTION
EXP.RX: MOVEI T,6 ;MOBY APPROXIMATION
SKIPA R,EXP.CF+6
EXP.3: FADR R,EXP.CF(T)
FMPR R,TT
SOJGE T,EXP.3
FADR R,FPWUN
FMPR R,R
FMPR F,R ;MULTIPLY FRACTION APPROXIMATION BY 10.↑<INTEGER PART>
MOVE TT,FPWUN
SKIPL EXP.S
SKIPA TT,F ;IF ARG>0, RETURN RESULT
FDVR TT,F ;IF ARG<0, RETURN 1.0/RESULT
POPJ P,
EXP.CF: 1.151292776 ;COEFFICIENTS FOR EXP APPROXIMATION
0.6627308843
0.2543935748
0.07295173666
0.01742111988
2.55491796↑-3
9.3264267↑-4
FPWUN: ;FLOATING POINT 1.0
INTLG: 1.0 ;TABLE OF 10.↑X FOR INTEGRAL 0<=X<=7
REPEAT 7, 1.0↑<.RPCNT+1>
C1.0E5=FPWUN+5
PGTOP ARI,[ARITHMETIC SUBROUTINES]
;;@ END OF ARITH 47
;;; REMEMBER THE SUNDER HACK, AND DONT HACK THIS $INSRT
IFN BIGNUM,[
;;@ BIGNUM 12 BIGNUM ARITHMETIC PACKAGE
PGBOT BIG
SUBTTL BIGNUM PACKAGE - RANDOM ROUTINES
;THE BIGNUM ARITHMETIC PAGE - SPECIAL STUFF FOR BIGNUM OPERATIONS ONLY
YPOCB: PUSH P,[NREVERSE]
BCOPY: HRRZ C,A ;COPIES A BIGNUM IN ACCUMULATOR A [INTERNAL FORMAT]
PUSH P,A
MOVEI AR1,(P) ;CLOBBERS C AR1 TT D
BCOP1: JUMPE C,POPAJ
HLRZ TT,(C)
MOVE TT,(TT)
PUSHJ P,C1CONS
HRRM A,(AR1)
HRRZ AR1,(AR1) ;UPDATE POINTER TO END OF LIST
HRRZ C,(C) ;GET NEXT OF LIST TO BE COPIED
JRST BCOP1
BNARSV: PUSH P,C ;SAVE ACCUMULATORS
PUSH P,AR1
PUSH P,AR2A
MOVEM F,FACD
MOVEM R,FACF
JRST (T)
BNARRS: POP P,AR2A ;RESTORE ACCUMULATORS
POP P,AR1
POP P,C
MOVE F,FACD
MOVE R,FACF
JRST (T)
PLOV: PUSH P,AR1 ;OVERFLO WHILE ADDING OR SUBBING TWO FIXNUMS
SKIPN TT,D
JRST PLOV2
TLNN TT,400000
MOVNS TT
TLZ TT,400000
PUSH FXP,TT
PUSHJ P,ABSOV
MOVE A,(A)
HLR B,(A)
POP FXP,(B)
SKIPL D
TLC A,-1
SKIPA D,A
PLOV2: MOVE D,BNM236
POP P,AR1
JRST T13
PL1BN: EXCH D,TT ;FIXNUM SUM MEETS BIGNUM ARG
PUSHJ P,BNCVTM
EXCH D,TT
JRST T11
TIMOV: MOVEM T,AGDBT ;OVERFLO WHILE MULING TWO FIXNUMS
PUSHJ P,BNCV
MOVE D,A
MOVE TT,AGDBT
PUSHJ P,BNCVTM
JRST BNTIM
TIM1BN: JUMPE D,T14EX ;FIXNUM PRODUCT MEETS BIGNUM NEXT ARG
EXCH D,TT
PUSHJ P,BNCVTM
EXCH D,TT
JRST T11
T2: MOVE D,TT
T12: MOVE A,(F) ;BIGNUM ARITHMETIC LOOP
JSP T,NVSKIP
XCT 4(R) ;OPERATE ON TWO BIGNUMS
JRST 2(R) ;DISPATCH TO OPERATE ON BIGNUM SUM WITH FIXED
EXCH D,TT ;CONVERT BIGNUM SUM TO FLOATING
PUSHJ P,FLBIG
EXCH D,TT
JRST T7 ;AND ENTER FLOATING POINT LOOP
PL2BN: PUSHJ P,BNCVTM ;BIGNUM SUM MEETS FIXNUM NEXT ARG
JRST T11
TIM2BN: JUMPE TT,T14EX1 ;BIGNUM PRODUCT MEETS FIXNUM NEXT ARG
PUSHJ P,BNCVTM
EXCH D,TT
T11: XCT 4(R) ;TRANSFERS TO BNTIM
T13: AOBJN F,T12
T13X: MOVE A,D
SUB P,PLUS8
JRST BNCONS
BNDF: JSP A,BNPL1 ;DIFFERENCE OF TWO BIGNUMS
BNPL: JSP A,BNPL1 ;PLUS OF TWO BIGNUMS
BNPL1: EXCH A,D
MOVE B,TT
JSP T,BNARSV
PUSHJ P,BNADD(D)-BNPL1
T19A: PUSHJ P,BNTRSZ ;SKIPS 2 IF ALL RIGHT
MOVE D,[1←43]
JRST T19B
MOVE D,A
HRRZ B,(A) ;WHAT IF OPERATE RESULTS IN SCRUNCHING
JUMPN B,T19C ;ACCUMULATED VALUE INTO ONE WORD?
HLRZ D,(A)
MOVE D,(D)
JUMPGE A,.+2
MOVNS D
T19B: JSP T,BNARRS
JRST 2,@[T14E]
T19C: JSP T,BNARRS
JRST T13
BNXTIM: JUMPE TT,0POPJ ;FIXNUM IN TT TIMES ABS(BIGNUM IN A)
HRRZ D,(A)
SETOM REMFL
PUSHJ P,BNCVTM ;CONVERT FIXNUM TO BIGNUM FOR BNMUL
BNTIM: JSP T,BNARSV ;PRODUCT OF TWO BIGNUMS
MOVE A,D
MOVE B,TT
PUSHJ P,BNMUL
JSP T,BNARRS
MOVE D,A
SKIPN REMFL
JRST T13
SETZM REMFL
JRST BNCONS ;FOR BNXTIM, CONS UP A REAL BIGNUM
DIVSEZ: SKIPA D,BNM235 ;DIVISION BY 1←43 [-2E35.]
REM2BN: JUMPE TT,BPDLNKJ
DV2BN: JSP T,BNARSV ;BIGNUM DIVIDEND GETS FIXNUM DIVISOR
MOVE A,D
JUMPN TT,DV2BN1
SKIPN RWG
JRST OVFLER
MOVEI TT,1 ;ON ATTEMPT TO DIVIDE BY ZERO [WHEN RWG NOT ZERO]
JUMPGE A,.+2
MOVNS TT
MOVEM TT,BNV1
MOVE B,BNV2
PUSHJ P,BNADD
JRST T19A
DV1BN: CAME D,[400000,,] ;FIXNUM DIVIDEND, BIGNUM DIVISOR
TDZA TT,TT ;ORDINARILY ZERO
SKIPA D,BNM235 ;BUT -4←41/4←41 => 1, NOT 0
JRST T14EX1
BNDV: MOVE B,TT ;BIGNUM QUOTIENT, BIGNUM DIVEND
MOVE A,D
JSP T,BNARSV
PUSHJ P,BNQUO
SKIPE REMFL
CAMN TT,XC-1
JRST T19A
SETZM REMFL
JSP T,BNARRS
MOVE D,A ;DIVIDE OUT NORMALIZATION
JRST DV2BN
DV2BN1: MOVEM A,NORMF ;SO DIVIDE A BIGNUM BY A REGULAR FIXNUM
PUSHJ P,REVERSE
MOVE AR1,NORMF ;AR1 HAS SIGN OF ORIGINAL ARG IN LH
HRR AR2A,A ;AR2A HAS SIGN OF PRODUCT ON COPY
HLL AR2A,AR1
JUMPGE TT,DV2BN2
MOVNS TT
JUMPL TT,DV2BN3 ;FOO! LOUSY SETZ CASE - PRODUCT WILL BE NEGATIVE
TLC AR2A,-1
DV2BN2: HRRZ C,(A)
MOVE D,TT
HLRZ F,(A)
MOVE F,(F)
MOVEI R,0
DIV R,D
MOVE TT,R
PUSHJ P,C1CONS
BNFXLP: MOVE B,A
JUMPE C,D1FIN
MOVE R,F
HLRZ F,(C)
MOVE F,(F)
DIV R,D
MOVE TT,R
PUSHJ P,C1CONS
HRRM B,(A)
HRRZ C,(C)
JRST BNFXLP
DV2BN3: MOVE TT,BNM235
JSP T,BNARRS
JRST BNDV
D1FIN: HLL A,AR2A
PUSHJ P,BNTRUN
EXCH A,AR2A
MOVEI B,NIL
PUSHJ P,RECLAIM ;RECLAIM ONLY FREE STORAGE
EXCH A,AR2A
SKIPN REMFL
JRST T19A
MOVE D,F
JUMPGE AR1,.+2
MOVNS D
JSP T,BNARRS
MOVEI B,TRUTH
PUSHJ P,RECLAIM ;RECLAIM QUOTIENT SPACE, SINCE ONLY REMAINDER NEEDED
JRST T14EX
SUBTTL GENERAL UTILITY ROUTINES FOR BIGNUM ARITHMETIC
BNTRUN: HRR AR1,A ;TRUNCATE OFF LEADING ZEROS FROM BIGNUM
HRRZ B,(AR1) ;PRESERVE LH OF AR1
JUMPE B,CPOPJ
BNTR4: MOVS C,(B)
SKIPE (C)
HRR AR1,B
HLRZ B,C
JUMPN B,BNTR4
HRRZ C,(AR1)
HLRM C,(AR1)
JUMPE C,CPOPJ ;EXIT IF THERE WERE NO LEADING ZEROS
EXCH A,C
PUSHJ P,RECLAIM ;OTHERWISE, RECLAIM SPACE OCCUPIED
EXCH A,C ; BY LIST HOLDING THEM (B IS ZERO)
POPJ P,
BNTRSZ: JUMPGE A,BNPJ2 ;SKIPS 2 IF NOT -1←43 IN BIGNUM FORMAT. ELSE NO SKIP
BNTRS1: HRRZ AR1,(A) ;MUNGS ONLY AR1
JUMPE AR1,BNPJ2
MOVS AR1,(AR1)
TLNE AR1,-1
JRST BNPJ2
HLL AR1,(AR1) ;ALL THIS KLUDGERY SO THAT RANDOM
TLNE AR1,-1 ; NUMERIC QUANTITIES WILL NOT GET
JRST BNPJ2 ; IN THE RIGHT HALF OF AR1
HRLZ AR1,(AR1)
TLC AR1,1
JUMPN AR1,BNPJ2
HLRZ AR1,(A)
SKIPN (AR1)
POPJ P,
BNPJ2: POP P,AR1
JRST 2(AR1)
BNCV: PUSH FXP,D
PUSHJ FXP,SAV5M1
PUSHJ P,BNCVTM
MOVE A,TT
PUSHJ P,BCOPY
JRST UUOSE1
BNCVTM: JUMPL TT,T16 ;CONVERT NUMBER IN TT TO INTERNAL BIGNUM
T17: MOVEM TT,BNV1
MOVE TT,BNV2
POPJ P,
T16: MOVNS TT
JUMPL TT,T23 ;400000,,
PUSHJ P,T17
TLCA TT,-1
T23: MOVE TT,BNM235 ;CONVERTED TO BIGNUM -2E35.
POPJ P,
SUBTTL BIGNUM ADDITION SUBROUTINE
BNSUB: TLC B,-1 ;CHANGE SIGN OF 2ND ARG
BNADD: MOVE C,A ;FIRST ARGUMENT TO C
HLLZ A,C ;SET UP NULL BIGNUM WITH SIGN OF FIRST ARG
PUSH P,A
HLLZ F,B ;DITTO SECOND ARG
MOVEI R,BNADD2 ;SET UP FOR REAL ADD
CAME A,F ;CHECK FOR SAME SIGNS
MOVEI R,BNSUB2 ;CHANGE TO SUBTRACT
MOVE F,P ;F POINTS TO BOTTOM WORD OF ANSWER
MOVEI TT,0 ;ARITHMETIC DONE IN TT
BN4: MOVE AR2A,C
MOVE C,(C) ;CDR C
MOVE B,(B) ;CDR B
BN15: MOVEI D,0 ;CLEAR CARRY
HLRZ AR1,C
ADD TT,(AR1)
HLRZ AR1,B
XCT -1(R) ;ADD/SUB TT,(AR1)
TLZE TT,400000 ;CARRY OR BORROW
MOVE D,-2(R) ;PLUS OR MINUS 1
JSP T,FWCONS
MOVE AR1,A
PUSHJ P,ACONS
HRRM A,(F) ;NCONC ONTO ANSWER
MOVE F,A ;UPDATE POINTER TO LAST WORD
BN20: TRNN B,-1 ;END OF SECOND ARG?
JRST @-3(R)
BN7: TRNN C,-1 ;END OF FIRST ARG?
JRST (R)
BN9: MOVE TT,D ;MOVE CARRY TO TT
JRST BN4
BN5
1 ;CARRY
ADD TT,(AR1)
BNADD2: JUMPN D,BN8 ;FIRST ARG DONE; IF CARRY, SIMULATE A ZERO
BN14: HRRM B,(F) ;USE REST OF SECOND ARG
JRST POPAJ
BN8: MOVEI C,[R70,,]
JRST BN9
BN5: JUMPN D,BN6 ;2ND ARG EXHAUSTED; IF CARRY, SIMULATE A ZERO
BN13: HRRM C,(F)
JRST POPAJ
BN6: MOVEI B,[R70,,]
JRST BN7
BN12
-1 ;BORROW
SUB TT,(AR1)
BNSUB2:
;COME HERE ONLY IF ABS(1)<ABS(2)
;FIRST ARG DONE, AND (2ND IS NOT DONE, OR THERE IS A BORROW)
;IT IS NECESSARY TO TAKE THE TWOS COMPLEMENT OF THE PARTIAL ANSWER
MOVE A,(P)
TLC A,-1
MOVEM A,(P)
MOVSI TT,400000 ;TT IS INITIALIZED TO 400000000000
;AND UNCHANGED WHILE THE PARTIAL ANSWER IS ZEROS
;AFTER A NONZERO WORD, TT IS RESET TO 377777777777 AFTER EACH SUBTRACT
SKIPA C,(A) ;SCAN DOWN NUMBER; LEFT HALF OF C NOW POINTS AT LOW ORDER WORD
BN10: MOVE C,(C)
HLRZ AR1,C
SUBB TT,(AR1)
SKIPL TT ;IFF TT IS STILL SETZ, (AR1) WAS ZERO AND MUST BE FIXED
SKIPA TT,[377777777777]
SETZM (AR1)
TRNE C,-1
JRST BN10
JUMPL D,BN11 ;IF BORROW: THE PARTIAL ANSWER WAS NONZERO TO GENERATE THE BORROW
;A RECOMPLEMENT BORROW OCCURED. TT IS 377777777777.
;SHOULD USE REST OF 2ND ARGUMENT
JUMPL TT,BN14 ;TT<0: THE PARTIAL ANSWER WAS ZERO; 1ST ARG IS PROPER INITIAL SEGMENT OF 2ND ARG
;USE REST OF 2ND ARG, GUARANTEED TO BE NONZERO
MOVNI TT,1 ;RECOMPLEMENT BORROW BUT NO ORIGINAL BORROW; USE REST OF 2ND ARG WITH BORROW
MOVE C,(B) ;SWAP ARGS
MOVSI B,[0]
JRST BN15 ;CONTINUE AS A SUBTRACT IN WHICH "2ND" ARG IS EXHAUSTED, AND A BORROW PROPAGATED
;CURIOUS THINGS HAPPEN IF THE REST OF "1ST" ARG IS ZERO(AN IMPROPER FORMAT)
BN11: TLNE B,-1 ;TRY TO AVOID USING THE TRUNCATE ROUTINE
JRST BN14 ;REST OF 2ND ARG IS NOT NULL, SO USE IT
BN11A: POP P,A
SKIPE (AR1) ;AR1 POINTS AT HIGH WORD OF DIFFERENCE
POPJ P,
JRST BNTRUN
BN12: JUMPN D,BN6 ;2ND ARG EXHAUSTED; IF BORROW, INVENT A ZERO
TRNE C,-1 ;IF 1ST ARG IS NOT EXHAUSTED, USE REST OF IT
JRST BN13
JRST BN11A ;BOTH ARGS EXHAUSTED
BNM1: JUMPE D,POPAJ ;SWAP OUT ONLY A NONZERO CARRY
PUSH P,CPOPAJ ;FOR MULTIPLICATION ROUTINE
BNM2: EXCH D,TT
JSP T,FWCONS
PUSHJ P,ACONS
EXCH D,TT
HRRM A,(R) ;NCONC CARRY WORD TO ANSWER BIGNUM
POPJ P,
SUBTTL BIGNUM MULTIPLICATION SUBROUTINE
;MULTIPLY IS DONE IN TWO PARTS: (1) MULTIPLY FIRST ARG BY FIRST WORD OF SECOND ARG
;(2) MULTIPLY [AND ADD IN TO TOTAL] FIRST ARG BY EACH REMAINING WORD OF THE SECOND ARG
;SLIGHTLY FASTER IF SECOND ARG IS SHORTER
BNMUL: MOVE C,A
HLLZ A,C ;CREATE NULL BIGNUM WITH SIGN OF FIRST ARG
XOR A,B ;SKIP IF 2ND ARG POSITIVE. CHANGE SIGN OF ANSWER
PUSH P,A
MOVE R,P ;R POINTS AT LAST WORD OF ANSWER BIGNUM DURING PART ONE OF MULTIPLY
MOVE B,(B) ;GET FIRST WORD OF SECOND ARG
HLRZ F,B
MOVE F,(F)
MOVEI D,0 ;ZERO CARRY WORD
SKIPA AR2A,(C) ;PREPARE TO GOBBLE FIRST ARG
BNM5: MOVE AR2A,(AR2A)
HLRZ T,AR2A ;GOBBLE A WORD OF FIRST ARG
MOVE T,(T)
MUL T,F ;AFTER MULTIPLY, T<377777777777
ADD TT,D ;CARRY<400000000000; SUM<777777777777
MOVE D,T
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS D ;NEW CARRY<400000000000
PUSHJ P,C1CONS
HRRM A,(R)
MOVE R,A ;UPDATE POINTER TO LAST WORD
TRNE AR2A,-1 ;END OF FIRST ARG?
JRST BNM5
MOVE A,(P)
HRRM A,BNMSV
BNM4: TRNN B,-1 ;END OF SECOND ARGUMENT?
JRST BNM1 ;YES; SWAP OUT CARRY IF NOT ZERO
PUSHJ P,BNM2
MOVE B,(B) ;GET NEXT WORD OF SECOND ARG
HLRZ F,B
MOVE F,(F)
MOVE R,@BNMSV
HRRM R,BNMSV
MOVE AR2A,(C) ;RESET FIRST ARGUMENT
MOVEI D,0 ;CLEAR OUT CARRY
BNM3: HLRZ T,AR2A ;GET A WORD OF FIRST ARG
MOVE T,(T)
MUL T,F ;AFTER MULTIPLY, T<377777777777
ADD TT,D ;CRY<400000000001, SUM<1000000000000
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS T ;NEW T<400000000000
HLRZ D,(R) ;GET WORD OF ACCUMULATOR
ADD TT,(D) ;SUM<777777777777
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS T ;NEW T<400000000001
MOVEM TT,(D) ;STORE WORD OF ACCUMULATOR
MOVE D,T
TRNN AR2A,-1 ;SKIP IF NOT END OF FIRST ARG
JRST BNM4
MOVE AR2A,(AR2A) ;ADVANCE TO NEXT WORD OF FIRST ARG
MOVE R,(R) ;ADVANCE TO NEXT WORD OF ACCUMULATOR
JRST BNM3
SUBTTL BIGNUM DIVISION SUBROUTINE
BNQUO: SETZM NORMF ;INITIALIZE NORMALIZATION FACTOR
SETZM VETBL0 ;INITIALIZE "FIRST TIME THRU" FLAG
PUSH P,B ;SETS UP TO TEST FIRST DIVISOR WORD
PUSH P,A
BNQUO1: MOVEI D,1
MOVE C,B
MOVE C,(C)
MOVE AR1,(C)
AOS D
TRNE AR1,-1
JRST .-4
HLRZS AR1
MOVE F,(AR1)
CAMGE F,[200000,,0] ;NORMALIZATION TEST
JRST BQNORM
SKIPN NORMF
JRST BQCOPY
MOVSS C ;GET TOP TWO DIVISOR WORDS
MOVE C,(C)
MOVEM F,DVS1
MOVEM C,DVS2
MOVEM D,DVSL
MOVEI C,(A) ;SET UP QUOTIENT
JUMPGE B,.+2
TLC A,-1
HLLZS A
TLZ B,-1 ;PROB. UNNECESSARY, BUT WHY TAKE CHANCES?
PUSH P,A
BQ1: MOVEI R,3 ;THIS GETS DVD WORDS FOR THE QUOTIENT ESTIMATE
MOVE AR2A,C
BQ2: MOVE AR2A,(AR2A)
TRNN AR2A,-1
JRST BQSRRM ;PARTIAL REMAINDER IS ONLY ONE WORD LONG
MOVE T,(AR2A)
TRNN T,-1
JRST BQSHRM ;PARTIAL REM OR DVD IS 2 WORDS LONG
MOVE TT,(T)
TRNE TT,-1
AOJA R,BQ2
JRST BQCC
BQCC: MOVSS AR2A
MOVE AR2A,(AR2A)
MOVEM AR2A,DD3
MOVSS T
MOVE T,(T)
MOVEM T,DD2
MOVSS TT
MOVE TT,(TT)
MOVEM TT,DD1
SKIPN VETBL0
JRST BQVET
MOVEM R,DDL
BQGEST: SUB R,DVSL ;CHECKS FOR PARTIAL REMAINDER<DIVISOR
JUMPL R,BQZQ
JUMPN R,BQGESS
EXCH R,DD1 ;SINCE R WAS 0, NOW DD1 IS 0
MOVEM R,DD2
JRST BQGESS
BQZQ: SETZM QHAT
JRST BQ8
BQCOPY: SETOM NORMF ;COPIES DIVIDEND TO GET WORK SPACE
PUSHJ P,BCOPY ;CLOBBERS T TT D B C AR1
MOVEM A,(P)
MOVE B,-1(P)
JRST BNQUO1
BQNORM: ADDI F,1 ;THIS SECTION MULTIPLIES DVD AND DIV BY NORMF
MOVEI T,1
SETZ TT,
DIV T,F
MOVEM T,NORMF
MOVE A,B
MOVEM T,BNV1
MOVE B,BNV2
PUSHJ P,BNMUL
EXCH A,(P)
MOVE B,BNV2
PUSHJ P,BNMUL
MOVE B,A
EXCH B,(P)
MOVEM B,-1(P)
JRST BNQUO1
BQ6:
BQSRRM: SETZM QHAT ;COME HERE IF PARTIAL REM IS ONE WORD
JRST BQ8 ;MEANS QUOTIENT AT THIS STEP IS ZERO
BQSHRM: MOVEI R,2 ;COME HERE IF PARTIAL REMAINDER IS 2 WORDS LONG
MOVSS AR2A
MOVSS T
MOVE T,(T)
MOVE AR2A,(AR2A)
MOVEM T,DD2
MOVEM AR2A,DD3
SETZM DD1
SKIPE VETBL0
JRST BQGESS
JRST BQ10
BQVET: MOVEM TT,DD2
MOVEM T,DD3
SETZM DD1
JRST BQ10
BQSHRT: MOVE A,-1(P)
JUMPE R,BQSH0
SKIPE REMFL
JRST REMFIN
HLLZS R
HRRM R,-1(P)
JRST BQ6
REMFIN: HLL A,-1(P)
TRNN A,-1
MOVE A,-1(P) ;IN CASE DIVIDEND IS REMAINDER
PUSHJ P,BNTRUN
MOVE TT,NORMF
SUB P,R70+3
POPJ P,
BQ10: SUB R,DVSL ;SETS UP INITIAL ZERO FOR FIRST GUESS
SKIPG R
JRST BQSHRT
SOSN R
JRST BQ1DF
MOVEM R,DDL
MOVE F,C
BQDD: MOVE F,(F)
MOVE TT,(F)
SOJLE R,BQ11
JRST BQDD
BQ11: MOVEI A,(TT)
MOVEI R,0
HRRM R,(F)
MOVE C,A
JRST BQGESS
BQ5: MOVE AR2A,[377777777777]
BQ7: MOVE A,C ;MULTIPLY,SUBTRACT,AND ADD BACK LOOP
MOVEM AR2A,QHAT
SETZB AR2A,AR1
MOVE B,-2(P)
MOVE D,QHAT
PUSHJ P,BQSUB
HLLZS (AR2A)
PUSHJ P,BNTRUN
BQ8: SETOM VETBL0 ;QUOTIENT STORING LOOP
SKIPE REMFL
JRST BQ9
MOVE AR1,A
EXCH TT,AGDBT
MOVE TT,QHAT
PUSHJ P,C1CONS
MOVE F,(P)
HRRM F,(A)
HRRM A,(P)
MOVE A,AR1
EXCH TT,AGDBT
BQ9: MOVE B,-1(P) ;BRING DOWN A NEW DVD WORD
TRNN B,-1
JRST BQFIN
MOVE C,(B)
TRNN C,-1
JRST BQEFIN
BQ9A: MOVE AR1,(C)
TRNN AR1,-1
JRST BQ9B
MOVE B,(B)
MOVE C,(B)
JRST BQ9A
BQ9B: MOVEI AR1,0
HRRM AR1,(B)
HRRM A,(C)
HRR A,C
PUSHJ P,BNTRUN
MOVE C,A
JRST BQ1
BQEFIN: MOVEI C,0
HRRM C,-1(P)
MOVE C,B
JRST BQ9B
BQSH0: HLLZS R
HRRM R,-1(P)
JRST BQGESS
BQ1DF: HRRZ A,(C)
MOVEI R,0
HRRM R,(C)
MOVE C,A
BQGESS: JRST 2,@[.+1]
MOVE D,DVS1 ;CLEARS NO DIVIDE FLAG
MOVE T,DD1
MOVE TT,DD2
DIV T,D
JSP R,.+1
TLNE R,40
JRST BQ5
JUMPE T,BQ6
MOVE AR2A,T
BQCHEK: MUL T,D
MOVE R,DD1
MOVE F,DD2
SUB F,TT
TLZ F,400000
MOVE R,F
MOVE F,DD3
MOVE T,DVS2
MUL T,AR2A
CAMG T,R
JRST BQC1
BQC2: SOJA AR2A,BQ7
BQC1: CAMN T,R
CAMG TT,F
JRST BQ7
JRST BQC2
BQFIN: SKIPE REMFL
JRST REMFIN
SETZB A,B
EXCH A,-1(P)
PUSHJ P,RECLAIM
EXCH A,-2(P) ;NOTE: RECLAIM RETURNED NIL
AOSE NORMF
PUSHJ P,RECLAIM
POP P,A
SUB P,R70+2
JRST BNTRUN
BQSUB: MOVEI R,0 ;THIS MULTIPLIES DIVISOR BY PARTIAL QUOTIENT ESTIMATE
BQSUB0: MOVE AR2A,A ;AND SUBTRACTS FROM THE PARTIAL REMAINDER
MOVE A,(A) ;AND ADDS BACK IF THE ESTIMATE WAS TOO LARGE
MOVE B,(B) ;THE NEW PARTIAL REMAINDER IS STORED IN
HLRZ T,B ;THE SAME WORDS AS THE OLD PART. REM.
MOVE T,(T)
MUL T,D
MOVS AR1,A
ADD TT,R
TLZE TT,400000
AOS T
EXCH TT,(AR1)
SUBB TT,(AR1)
TLZE TT,400000
AOS T
MOVEM TT,(AR1)
TRNN B,-1
JRST BQSUB1
BQSUB7: TRNN A,-1
JRST BQSUB3
MOVE R,T
JRST BQSUB0
BQSUB1: JUMPN T,BQSUB6
MOVE A,C
POPJ P,
BQSUB6: MOVEI B,[R70,,NIL]
JRST BQSUB7
;;; KNUTH SAYS THE FOLLOWING PIECE OF CODE (ADDING BACK) IS
;;; NEEDED IN ONLY ABOUT 3 OR 4 CASES IN 34 BILLION. HERE
;;; ARE TWO NUMBERS ACCIDENTALLY DISCOVERED BY GOSPER WHICH
;;; WILL CAUSE THIS ADDING BACK TO HAPPEN:
;;; THE DIVIDEND IS:
;;; 2791789817939938387128631852330682768655711099796886
;;; 76652915704481188064205113686384821261582354
;;; 6679451522036433421137784129286923496509.
;;; THE DIVISOR IS:
;;; 888654299197548479101428655285643704385285845048283
;;; 973585973531.
;;; TO SEE WHY HE DISCOVERED IT, TRY LOOKING AT THE QUOTIENT!
;;;
;;; HERE ARE TWO MORE NUMBERS WHICH EXCUTE THIS CODE; FURTHERMORE,
;;; THEY CAUSE THE OVER-SUBTRACTED DIVIDEND TO BE SHORTER THAN
;;; THE DIVISOR; THIS IS THE REASON FOR THE COPYING BELOW.
;;; (GOSPER ALSO DISCOVERED THESE NUMBERS!)
;;; THE DIVIDEND IS:
;;; 814814390533794434507378275363751264420699600792121
;;; 5135985742227369051304412442580926595072.
;;; THE DIVISOR IS:
;;; 10889035741470030830827987437816582766593.
BQSUB3: HLLZS (AR2A) ;CHOP OFF END OF ANSWER STORAGE
MOVE A,C
PUSHJ P,BNTRUN ;TRUNCATE ANSWER, WHICH IS A NEGATIVE NUMBER IN POSITIVE FORM
PUSH P,A
HRRZ A,-4(P) ;GET (ABSOLUTE VALUE OF) DIVISOR
PUSHJ P,BCOPY ;MUST COPY IT, OR ELSE CARRY
POP P,B ; TRUNCATION MIGHT CLOBBER IT!
PUSHJ P,BNADD ;SET UP ANSWER FOR ADD BACK
SKIPA B,A
BQSUB4: MOVE B,(B) ;CHOP OFF CARRY
MOVE C,(B)
HRRZ AR1,(C)
JUMPN AR1,BQSUB4
MOVE AR2A,B ;CARRY WILL BE CHOPPED OFF WHEN THIS POPJ'S
SOS QHAT ;CORRECT QUOTIENT GUESS
POPJ P,
SUBTTL BIGNUM TO FLONUM CONVERSION
FLBIGF: JUMPN R,FLBIG
PUSH P,CFLOAT1
FLBIG: PUSHJ P,SAVX5 ;RECEIVES BIGNUM HEADER IN TT,
HLRZ A,TT ;LEAVES SIGN BIT IN AC A
HRRZ T,(TT) ;LEAVES RESULT AS NUMERIC IN TT
JUMPE T,FLTB1 ;SAVES ALL OTHER ACS
PUSHJ P,FLBIGZ
FADR TT,D ;ROUND UP
SKIPE RWG
JFCL 8.,FLBIGX
JFCL 8.,FLBIGO
FLBIGX: JUMPE A,.+2
MOVNS TT
MOVEM TT,-3(FXP)
JRST RSTX5
FLBIGZ: PUSHJ P,1HAU ;MUST BE > 27. BITS, OR ELSE WOULDN'T BE HERE
MOVEI T,(TT)
MOVEI D,27.
PUSHJ P,1HAI1 ;1HAI1 LEAVES TRAILING BITS IN TT+1
ASH TT+1,-8.
TLO TT,200000 ;INSTALL EXPONENTS
TLO TT+1,145000
JFCL 8.,.+1
TRNE T,-1#377 ;INSURE OVERFLOW IF EXPONENT IS TOO LARGE
TRO T,377
FSC TT,(T)
FSC TT+1,(T)
POPJ P,
FLTB1: HLRZ TT,(TT)
MOVE TT,(TT) ;ONE-WORD BIGNUM?
JSP T,IFLOAT
MOVE D,TT
JRST FLBIGX
FLBIGQ: HRROS (P) ;HACK SO THAT (*QUO <FLONUM> <HUGE-BIGNUM>)
JRST FLBIG ; WILL CAUSE UNDERFLOW, NOT OVERFLOW
FLBIGO: PUSHJ P,RSTX5
POP P,T
TLNN T,1 ;IF BIT 3.1 IS SET, SO IS 4.7 (SEE T7O0)
JRST OVFLER
AOJA T,T7O0
SUBTTL FLONUM TO BIGNUM CONVERSION
FIXBIG: JUMPN R,[LERR [SIXBIT \FIX HAS BIGNUM FOR ASSIGNMENT TO FIXNUM VARIABLE?!\]]
MOVE TT,T
MULI TT,400
JSP T,BNARSV
MOVE AR1,A
MOVE F,D
SUBI TT,200
IDIVI TT,43
SETZ R,
ASHC R,(D)
MOVE D,TT
JUMPE R,FXBFQ
MOVE TT,R
JSP T,FWCONS
PUSHJ P,NCONS
MOVE TT,F
MOVE C,A
FXBFV: JSP T,FWCONS
PUSHJ P,NCONS
HRRM C,(A)
MOVEI C,(A)
FXBFZ: SOJLE D,FBFIN
MOVEI TT,0
PUSHJ P,C1CONS
HRRM C,(A)
MOVEI C,(A)
JRST FXBFZ
FBFIN: SKIPG (AR1)
TLC A,-1
JSP T,BNARRS
JRST BNCONS
FXBFQ: MOVEI C,0
MOVE TT,F
JRST FXBFV
MNSBG: TLC TT,-1 ;MINUS, FOR BIGNUM
MOVE A,TT
4CHKRT: PUSHJ P,BNTRSZ ;FOR 100000000000, CONVERT
MOVE TT,[1←43] ; TO FIXNUM SETZ, ELSE
JRST FIX1
JRST BNCONS ; TO A REGULAR BIGNUM
SUBTTL ABS AND REMAINDER FOR BIGNUMS
ABSBG0: MOVE TT,(A)
ABSBG: JUMPGE TT,CPOPJ ;ABS FOR BIGNUM
HRRZ A,TT
JRST BGNMAK
REMBIG: EXCH A,B
MOVE D,TT ;REMAINDER FOR BIGNUM
SETZM PLUS8 ;SO THAT ARITHMETIC LOOP WILL RESTORE TO HERE
SETOM REMFL
JSP T,NVSKIP
JRST BNDV ;REMFL WILL STOP ARITHMETIC LOOP
JRST REM2BN
JSP T,REMAIR ;FOO! FLONUM ARG NOT COMPREHENSIBLE!
GRBB: SETZM NORMF ;GREATERP FOR BIGNUM WITH BIGNUM
MOVE A,D
MOVE B,TT
MOVE AR1,D
MOVE AR2A,TT
ASH TT,-43
ASH D,-43
CAME D,TT
JRST GRB13
SETO C,
GRBBL: TRNN AR1,-1
JRST GRB1
TRNN AR2A,-1
JRST GRB2
MOVS AR1,(AR1)
MOVS AR2A,(AR2A)
MOVE D,(AR1)
MOVE TT,(AR2A)
JUMPGE A,.+3
MOVNS D
MOVNS TT
XCT GRESS0
JRST GRBF
SETZ C,
GRBR: MOVSS AR1
MOVSS AR2A
JRST GRBBL
SUBTTL GREATERP AND LESSP FOR BIGNUMS
GRFXB: SETZM NORMF ;GREATERP FOR FIXNUM WITH BIGNUM
PUSH FXP,D
MOVE B,TT
MOVEI AR2A,QBIGNUM
MOVEI AR1,QFIXNUM
TLNE D,400000
SKIPA D,XC-1
MOVEI D,1
JRST GRB14
GRBFX: SETZM NORMF ;GREATERP FOR BIGNUM WITH FIXNUM
PUSH FXP,TT
MOVE A,D
MOVEI AR1,QBIGNUM
MOVEI AR2A,QFIXNUM
TLNE TT,400000
SKIPA TT,XC-1
MOVEI TT,1
JRST GRB14
GRBF: CAMN D,TT
JRST GRBR
SETO C,
JRST GRBR
GRB1: TRNN AR2A,-1
JRST GRBBEL
MOVEI D,2
MOVEI TT,4
GRB12: TLNE A,1
EXCH D,TT
GRB13: MOVEI AR1,QBIGNUM
MOVEI AR2A,QBIGNUM
GRB14: XCT GRESS0
SKIPA C,[-1]
MOVEI C,0
JRST GRBBE2
GRB2: SETOM NORMF
MOVEI D,4
MOVEI TT,2
JRST GRB12
GRBBEL: MOVEI AR1,QBIGNUM
MOVEI AR2A,QBIGNUM
GRBBE2: MOVE D,A
MOVE TT,B
CAIN AR2A,QFIXNUM
POP FXP,TT
CAIN AR1,QFIXNUM
POP FXP,D
SKIPE NORMF
MOVNS C
SKIPN C
XCT CSUCE
XCT CFAIL
SUBTTL HAIPART FOR BIGNUMS
IFN USELESS,[
1HAI: JSP T,FXNV2
JUMPLE D,3HAI
PUSH FXP,D
PUSHJ P,1HAU
POP FXP,D
CAILE D,35.
JRST 2HAI
PUSH P,CFIX1
] ;END OF IFN USELESS
;IN USELESS VERSION, 1HAI CALLED ONLY BY FLBIG
1HAI1: ADDI R,-35.-1(D) ;FINAL ANSWER FITS IN ONE WORD
HLRZ D,(F) ;SPREAD OUT HIGH WORD AND
MOVE D,(D) ;NEXT-TO-HIGH WORD INTO TT,D
HRRZ TT,(F)
HLRZ TT,(TT)
MOVE TT,(TT)
ASHC TT,(R)
POPJ P,
IFN USELESS,[
2HAI: SUBI TT,(D)
JUMPLE TT,CPOPJ
PUSHJ FXP,SAV3 ;COPY BIGNUM, BUT TOSS OUT LOW ORDER BITS
IDIVI TT,35. ;HOW MANY BITS TO THROW AWAY
MOVEI F,(A)
HRRZ F,(F)
SOJGE TT,.-1
MOVN C,D
SUBI D,35.
HLRZ TT,(F)
MOVE TT,(TT)
HRRZ F,(F) ;F IS CDR'ING DOWN INPUT
JUMPE F,2HAI0
HLRZ T,(F)
MOVE T,(T) ;C HOLDS AMNT TO SHIFT RIGHT BY
ASHC T,(C)
PUSHJ P,C1CONS
MOVEI B,(A)
2HAI2: MOVEI R,(A) ;R HAS PTR TO LAST OF FORMING LIST
HRRZ F,(F)
JUMPE F,2HAI3
ASHC T,(D) ;MOVE T INTO TT
HLRZ T,(F)
MOVE T,(T)
ASHC T,(C)
PUSHJ P,C1CONS
HRRM A,(R)
JRST 2HAI2
2HAI0: ASH TT,(C) ;DEFINITELY A BUG TO COME HERE,SINCE WE
JSP R,RSTR3
JRST FIX1 ;THINK WE ARE RETURNING A BIGNUM
2HAI3: JUMPE T,2HAI4
MOVE TT,T
PUSHJ P,C1CONS
HRRM A,(R)
2HAI4: MOVEI A,(B)
PUSHJ P,BGNMAK
POP P,C
JRST POP2J
] ;END OF IFN USELESS
;;; THE CODE FOR 3HAI IS PUTCODED.
IFN USELESS,[
SUBTTL GCD FOR BIGNUMS
GCDBG: MOVEI F,1 ;INITIALIZE SMALLNUM MATRIX
MOVEM F,GCD.A
MOVEM F,GCD.D
SETZM GCD.B
SETZM GCD.C
HLRZ R,(TT) ;GET LOW ORDER WDS OF ARGS
MOVE R,(R)
HLRZ F,(D)
MOVE T,R ;LOW WD OF U
IOR R,(F)
PUSH FXP,R
JUMPE R,GCDBG4 ;BOTH LOW WDS 0
MOVN R,R
ANDM R,(FXP) ;GRTST COMMON PWR OF 2 OR 0 IF > 2↑35.
PUSH FXP,(F) ;LOW WD OF V.
JUMPN T,GCDBG0 ;IF T=0 AND (F) EVEN, XTRA PWR OF 2 WILL
EXCH A,B ; COME BACK FROM RECURSION, SO SWAP TO
EXCH TT,D ; UNZERO T, THUS GUARANTEEING RECURSION WITH
EXCH T,(FXP) ; AT LEAST 1 ODD ARG.
GCDBG0: MOVEI R,(TT) ;GET HI WDS IF SAME LENGTH.
MOVEI F,(D)
HRRZ D,(D)
HRRZ TT,(TT)
JUMPE D,GCDBG2
JUMPN TT,GCDBG0
EXCH A,B ;B IS LONGER THAN A
GCDBG1: SUB FXP,R70+2
PUSH P,B ;A IS LONGER THAN B
PUSHJ P,REMAINDER ;SO GCD(A,B) = GCD(REMAINDER(A,B),B)
POP P,B
JRST GCD
GCDBG2: JUMPN TT,GCDBG1 ;U,V UNEQUALLY LONG
HLRZ R,(R) ;U,V EQUALLY LONG,
HLRZ F,(F) ; GET ACTUAL HI WDS.
MOVE TT,(R)
MOVE D,(F)
POP FXP,R ;TT,D HAVE HI WDS (OR 0 AND NON0 IF UNEQUAL LENGTH)
MOVEI F,35. ;T,R HAVE LO WDS
MOVEM F,GCD.UH ;SHFT CTR
GCDBGU: TRNE T,1
JRST GCDBGV ;U IS ODD
GCDBHU: LSH T,-1
LSH D,1 ;TT RIGHT 1 REL TO D
JUMPGE D,.+3
LSH D,-1
LSH TT,-1
MOVE F,GCD.C ;HALVING A, B EQUIV TO DOUBLING C,D
ADDM F,GCD.C
MOVE F,GCD.D
ADDM F,GCD.D
SOSE GCD.UH
JRST GCDBGU
GCDBG4: PUSH P,A
PUSH P,B
MOVE TT,GCD.A
PUSHJ P,BNXTIM
PUSH P,A ;T <- A*U
MOVE A,-1(P)
MOVE TT,GCD.B
PUSHJ P,BNXTIM
POP P,B
PUSHJ P,.PLUS ;T <- T+B*V
PUSHJ P,BNLWFL
EXCH A,-1(P)
MOVE TT,GCD.C
PUSHJ P,BNXTIM
EXCH A,(P) ;W <- C*U
MOVE TT,GCD.D
PUSHJ P,BNXTIM
POP P,B
PUSHJ P,.PLUS ;W <- W+D*V
PUSHJ P,BNLWFL
POP P,B ;U <- T
POP FXP,TT
CAIN TT,1
JRST GCD
PUSH FXP,TT
PUSHJ P,GCD
MOVEI B,(FXP)
SKIPN (B)
MOVEI B,BN235 ;CAN ONLY HAPPEN WHEN BOTH LO WDS 0
PUSHJ P,.TIMES
SUB FXP,R70+1
POPJ P,
GCDBGV: TRNE R,1
JRST GCDBGO ;BOTH U,V ODD
GCDBHV: LSH R,-1
LSH TT,1
JUMPGE TT,.+3
LSH TT,-1
LSH D,-1
MOVE F,GCD.A
ADDM F,GCD.A
MOVE F,GCD.B
ADDM F,GCD.B
SOSE GCD.UH
JRST GCDBGV
JRST GCDBG4
BNLWFL: SKIPN B,(A) ;FLUSH LO 35 0S OF A
POPJ P, ;A WAS 0
HRRZ B,(B)
HRRZ C,(B)
JUMPE C,BNLWFX ;IF BIGNUM BECOMES FIXNUM
HRRM B,(A)
POPJ P,
BNLWFX: HLRZ A,(B)
POPJ P,
GCDBGO: CAML TT,D
JRST GCDBGT
SUB D,TT
SUB R,T
MOVN F,GCD.A
ADDM F,GCD.C
MOVN F,GCD.B
ADDM F,GCD.D
JRST GCDBHV
GCDBGT: SUB TT,D
SUB T,R
MOVN F,GCD.C
ADDM F,GCD.A
MOVN F,GCD.D
ADDM F,GCD.B
JRST GCDBHU
GCDBX: SKIPN D,(B) ;FIXNUM IS ZERO - RETURN BIGNUM
JRST ABSBG0 ;MAYBE NEED TO TAKE ABS VALUE
CAMN D,[400000,,] ;CHECK FOR NASTY -400000000000 CASE
JRST GCDOV
PUSH P,B ;ELSE TAKE A REMAINDER
PUSHJ P,REMAINDER
POP P,B
JRST .GCD ;GUARANTEED TO HAVE TWO FIXNUMS NOW
GCDOV: MOVEI B,(A) ;HANDLE NASTY -400000000000 CASES
GCDOV1: PUSHJ P,ABSOV
JRST GCD
] ;END OF IFN USELESS
PGTOP BIG,[BIGNUM-ONLY ARITHMETICS]
;;@ END OF BIGNUM 12
]
SUBTTL EVAL AND EVALHOOK
PGBOT EVL
EVALHOOK:
JSP TT,LWNACK
LA23,,QEVALHOOK
IFE FUNAFL,[
MOVEI D,QEVALHOOK
CAME T,XC-2
JRST WNALOSE
] ;END OF IFE FUNAFL
POP P,B
AOS D,T
JSP T,SPECBIND
0 B,VEVALHOOK
IFN FUNAFL,[
CAMN D,XC-2
PUSHJ FXP,AEVAL ;SKIP RETURN
] ;END OF IFN FUNAFL
POP P,A
PUSH P,CUNBIND
SKIPN V.RSET
JRST EV0
JRST EVAL0
OEVAL:
IFN FUNAFL,[
JSP TT,LWNACK ;"EXTERNAL" EVAL - LSUBR (1 . 2)
LA12,,QOEVAL ;MAY TAKE ALIST AS SECOND ARG
CAMN T,XC-2
PUSHJ FXP,AEVAL ;SKIP RETURN
] ;END OF IFN FUNAFL
IFE FUNAFL,[
AOJE T,.+3
MOVEI D,QOEVAL
SOJA T,WNALOSE
] ;END OF IFE FUNAFL
POP P,A
EVAL: SKIPN V.RSET ;"INTERNAL" EVAL - ARG IN A
JRST EV0
SKIPN B,VEVALHOOK
JRST EVAL0
JSP T,SPECBIND ;SUPER-RANDOM HACK SO THAT MM
VEVALHOOK ; CAN INVENT A ↑N FOR LISP
CALLF 1,(B)
JRST UNBIND
EVAL0: SKIPE NIL
PUSHJ P,NILBAD
PUSH P,FXP ;EVAL FRAME FORMAT:
HRLM FLP,(P) ; FLP,,FXP
PUSH P,A ; SP,,<FORM>
HRLM SP,(P) ; $EVALFRAME
PUSH P,[$EVALFRAME] ;SEE APPLY FOR FORMAT OF APPLY FRAMES
;FALLS THROUGH
;FALLS IN
;;; EVALUATE A FORM IN A
EV0: JUMPE A,CPOPJ ;NIL => NIL, ALWAYS!!!
MOVEI C,ILIST
SKOTT A,LS
2DIF JRST (TT),EVTB1-1,QLIST .SEE STDISP
EV0A: MOVE AR1,(A) ;FUNCTION ON 0(P), ADDRESS TO JRST TO IN (TT)
HLRZ T,(A)
SKOTT T,LS
2DIF JRST (TT),EVTB2-1,QLIST .SEE STDISP
HLRZ TT,(T)
CAIN TT,QLAMBDA
JRST EXP3
IFN FUNAFL,[
CAIE TT,QFUNARG
CAIN TT,QLABEL
JRST EXP3
] ;END OF IFN FUNAFL
JUMPL C,EV3B
SKIPE B,VOEVAL
JCALLF 1,(B) ;EVALSHUNT
HLRZ A,AR1
TLNN C,777740 ;MAYBE SAVE FUNCTION NAME IN EV0B
MOVEM A,EV0B
PUSH P,EV0B ;NON-ATOMIC FUNCTION, NOT LAMBDA,
PUSH P,C ; LABEL, OR FUNARG
PUSH P,AR1
PUSHJ P,EV0 ;SO EVALUATE THE FORM
POP P,AR1
POP P,C
POP P,EV0B
JRST EV4 ;NOW TRY USING THE RESULT AS A FUNCTION
EVTB1: JRST PDLNKJ ;FIXNUMS EVALUATE TO THEMSELVES
JRST PDLNKJ ;DITTO FLONUMS
BG$ POPJ P, ;GUESS WHAT, FELLAHS
JRST EE1 ;SOME HAIR FOR SYMBOLS
REPEAT HNKLOG, .VALUE ;HUNKS
JRST EV2 ;RANDOMS LOSE
POPJ P, ;ARRAYS EVAL TO SELVES
IFN .-EVTB1-NTYPES+1, WARN [WRONG LENGTH TABLE]
EV2: %WTA EMS25 ;UNEVALUABLE DATUM (RANDOMNESS)
JRST EV0
EVTB2: JRST EV3A ;FIXNUM AS A FUNCTION IS AN ERROR
JRST EV3A ;DITTO FLONUM
BG$ JRST EV3A ;DITTO BIGNUM
JRST EE2 ;SYMBOLS - THE GOOD CASE
REPEAT HNKLOG, .VALUE ;HUNKS
JRST EV3A ;IT'S A TRULY RANDOM FUNCTION!
JRST ESAR ;IT'S AN ARRAY
IFN .-EVTB2-NTYPES+1, WARN [WRONG LENGTH TABLE]
EE1: PUSHJ P,EVSYM ;EVALUATE SYMBOL
POPJ P, ;WIN
JRST EV0 ;LOSE - RETRY
EE2: SETZ R, ;ZERO R FOR HACK TO TRAP AUTOLOAD LOSS
EE2A: HRRZ T,(T) ;CAR (X) IS ATOMIC
JUMPE T,EAL2 ;GET FUNCTION DEFINITION OFF ATOM
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY ;SYMBOL HEADERS FOR FUNCTION MARKERS
CAILE TT,QAUTOLOAD ; ARE LINEAR IN MEMORY
JRST EE2A
2DIF JRST @(TT),ETT,QARRAY
ETT: EAR ;ARRAY
ESB ;SUBR
EFS ;FSUBR
ELSB ;LSUBR
AEXP ;EXPR
EFX ;FEXPR
EFM ;MACRO
EAL ;AUTOLOAD
EAL: HRRI R,(T) ;NOTE THAT WE SAW AUTOLOAD PROPERTY
JRST EE2A
EAL2: JUMPL R,EV3J ;FN UNDEF AFTER AUTOLOAD
JUMPE R,EV3 ;NO AUTOLOAD PROP - TRY EVALING ATOM
MOVEI B,(R)
HLRZ T,(A)
PUSHJ P,IIAL
HLRZ T,(A)
SETO R,
JRST EE2A
EFM: CAIE C,ILIST ;FOUND MACRO
EFMER: LERR EMS21 ;IMPROPER USE OF MACRO
MOVE B,AR1
HLRZ AR1,(T) ;COMMENT THIS CROCK
CAIN A,AR1
PUSHJ P,CONS1
CALLF 1,(AR1) ;SO HAND THE FORM TO THE MACRO
JRST EVAL ; AND RE-EVALUATE THE RESULT
EFX: HLRZ T,(T) ;FOUND FEXPR
HLL T,AR1 ;SO A FEXPR BEHAVES LIKE AN EXPR
PUSH P,T ; WHOSE ONE ARG IS CDR OF THE FORM
HRLI AR1,400000 ;SEE IAP4 FOR EXPLANATION OF THIS HACK
PUSH P,AR1 ; WHICH ALLOWS FEXPRS AN ALIST ARG
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T) ;FOUND EXPR
HLL T,AR1
EXP3: PUSH P,T ;FOUND LAMBDA, LABEL, FUNARG
MOVEI A,(AR1)
CIAPPLY: MOVEI TT,IAPPLY
JRST (C)
EFS: HLRZ T,(T) ;FOUND FSUBR
MOVEI C,ESB3 ;THIS IS SO WE DON'T EVAL THE ARGS!
JRST ESB2
ELSB: PUSH P,CPOPJ ;FOUND LSUBR
HLLM AR1,(P)
MOVE R,T
HLL R,AR1
MOVEI TT,ELSB1
HRRZ A,AR1
JRST (C)
ELSB1: MOVEI A,NIL ;A HAS NIL WHEN ENTERING AN LSUBR
HLRZ D,(R)
SKIPN V.RSET
JRST (D)
HLRZ R,R
PUSHJ P,ARGCK0 ;CHECK OUT NUMBER OF ARGS
JRST ESB6
JRST (D)
ESAR: SKIPA TT,T ;FOUND SAR
EAR: HLRZ TT,(T) ;FOUND ARRAY
MOVEI R,(TT)
SKOTT TT,SA
JRST EV3A
EAR3: HRRZ T,ASAR(R)
CAIN T,ADEAD
JRST EV3A ;AHA! THIS ARRAY IS DEAD!
PUSH P,R
MOVEI T,EAR1 ;MUST DO SOME HAIR SO THAT
JRST ESB4 ; INTERRUPTS WON'T SCREW US
EAR1: MOVE T,LISAR ;DO NOT MERGE THIS WITH IAPAR1
JRST @ASAR(T) ; - SEE ESB3
ESB: HLRZ R,AR1 ;FOUND SUBR
HLRZ T,(T)
ESB4: MOVEI TT,ESB1
ESB2: MOVEI A,(AR1) ;A GETS LIST OF ARGS
HLL T,AR1
PUSH P,T ;STORE ADDRESS OF SUBROUTINE FOR FN
JRST (C) ;GO SOMEWHERE OR OTHER
ESB1: PUSHJ P,ARGCHK
JRST ESB6
MOVE TT,[A,,A+1]
MOVEI A,Q..MIS
BLT TT,A+NACS-1
JSP R,PDLA2(T)
ESB3: HRRZ TT,(P)
CAIN TT,EAR1 ;HACK TO HELP EAR1 WIN
JRST ESB3C
ESB3A: SKIPN V.RSET
POPJ P, ;ADDRESS OF SUBR IS ON STACK
MOVEI TT,CPOPJ ;WELL, MAYBE DO SOME *RSET HAIR
HLL TT,(P)
EXCH TT,(P)
JRST (TT)
ESB3C: HRRZ TT,-1(P)
MOVEM TT,LISAR ;SAR PROTECTED BY BEING IN LISAR
POP P,-1(P)
JRST ESB3A
EV3: JUMPL C,EV3B ;C<0 => TOO MANY RE-EVALS OF A FN
HLRZ A,AR1
HLRZ A,(A)
HRRZ A,@(A) ;GET VALUE OF ATOMIC FUNCTION
CAIN A,QUNBOUND ;IT'S UNBOUND. LOSE, LOSE, LOSE...
JRST EV3A
TLNN C,777740 ;SAVE FN NAME IN EV0B, MAYBE
HLRZM AR1,EV0B
EV4: ADD C,[1←34.] ;THIS SIZE OF THIS QUANTITY CONSTRAINS
EV4B: HRL AR1,A ; THE # OF TIMES WE MAY RE-EVAL THE FN
MOVEI A,AR1
JRST EV0A
SUBTTL SYMEVAL
SYMEV0: %WTA NASER
SYMEVAL: JUMPE A,CPOPJ ;SUBR 1
JSP T,SPATOM
JRST SYMEV0
PUSHJ P,EVSYM
POPJ P, ;WON
JRST SYMEVAL ;LOST
;;; EVALUATE ATOMIC SYMBOL. SKIPS ON FAILURE (AFTER DOING ERROR).
EVSYM: HLRZ T,(A) ;T GETS POINTER TO SYMBOL BLOCK
HRRZ T,@(T) ;AR1 GETS VALUE FROM VALUE CELL!!!
CAIN T,QUNBOUND
JRST EE1A ;FOOBAR! VALUE CELL CONTAINS UNBOUND
MOVEI A,(T) ;SO THE VALUE IS THE RESULT OF EVAL
POPJ P,
EE1A: %UBV MES6 ;UNBOUND VAR
JRST POPJ1
;;; END OF EVSYM ROUTINE
SUBTTL APPLY, *APPLY, SUBRCALL, LSUBRCALL, ARRAYCALL, FUNCALL
APPLY: CAME T,XC-2 ;"EXTERNAL" APPLY - SUBR (2 . 3)
JRST AP4 ;MAY TAKE A THIRD ALIST ARG
JSP R,PDLA2(T)
.APPLY: ;SUBR 2 (*APPLY)
AP3: SKIPN V.RSET
JRST AP3A
PUSH P,B
PUSH P,FXP
HRLM FLP,(P)
PUSH P,A
HRLM SP,(P)
PUSH P,[$APPLYFRAME]
AP3A: MOVEI AR1,(B) ;"INTERNAL" APPLY -
HRL AR1,A ; FUNCTION IN A, LIST OF ARGS IN B
MOVEI A,AR1
MOVEI C,AP2 ;THIS CROCK LETS US SHARE CODE WITH
JRST EV0A ; EVAL BY PREVENTING EVAL'ING OF ARGS
AP2: MOVEI T,0 ;DE-LISTIFY THE ARGS AND STACK THEM
JUMPE A,(TT) ; ON THE PDL, AND ALSO COUNT THEM
PUSH P,(A) ;DOING THINGS THIS WAY AVOIDS
HLRZS (P) ; DESTROYING ANY OTHER ACS
HRRZ A,(A)
SOJA T,.-4
AP4:
IFN FUNAFL,[
JSP TT,LWNACK ;APPLY WITH AN ALIST (GOOD GRIEF!)
LA23,,QAPPLY
MOVEM T,APFNG1
SKIPE A,(P) ;PURPOSELY CRIPPLING THE POWER OF
JSP T,FXNV1 ; THE ALIST ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;SO CREATE MORONIC ALIST ENVIRONMENT
EXCH T,APFNG1
JSP R,PDLA2(T)
SKIPE APFNG1 ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
JRST AP3
] ;END OF IFN FUNAFL
IFE FUNAFL,[
MOVEI D,QAPPLY
JRST WNALOSE
] ;END OF IFE FUNAFL
SUBRCALL: JSP TT,FWNACK ;LSUBR (2 . 7)
FA234567,,QSUBRCALL
JSP TT,JLIST
ADDI T,1
JSP R,PDLARG
POP P,TT
JSP D,PTRCHK
PUSHJ P,(TT)
RETTYP: POP P,D ;PURELY FOR TYPE CHECKING
CAIN D,QFIXNUM
JSP T,FXNV1
CAIN D,QFLONUM
JSP T,FLNV1
POPJ P,
%LSUBRCALL: JSP TT,FWNACK ;FSUBR
FA2N,,Q%LSUBRCALL
JSP TT,JLIST
MOVEI D,(P)
ADDI D,(T)
MOVEI TT,RETTYP
EXCH TT,1(D)
JSP D,PTRCHK
AOJA T,(TT)
PTRCHK: CAIL TT,BEGFUN
CAIL TT,ENDFUN
JRST .+2
JRST (D)
CAML TT,BPSL
CAML TT,@VBPORG
JRST PTRCKE
JRST (D)
%ARRAYCALL: JSP TT,FWNACK ;FSUBR
FA76543,,Q%ARRAYCALL
JSP TT,JLIST
MOVEI D,(T)
ADDI D,(P) ;FALLS INTO FUNCALL
%ARR7: HRRZ A,1(D)
SKOTT A,SA
SOJA T,%ARR0
MOVEI B,CPOPJ
EXCH B,(D)
HLRZ TT,@1(D) .SEE ASAR
MOVEI F,AS<SX>
CAIN B,QFIXNUM
MOVEI F,AS<FX>
CAIN B,QFLONUM
MOVEI F,AS<FL>
TRNN TT,(F)
JRST %ARR0A
FUNCALL: MOVEI D,QFUNCALL ;LSUBR (1 . 777)
JUMPE T,WNALOSE ;(FUNCALL F X1 X2 ... XN) IS LIKE
FUNCA1: SKIPN V.RSET ; (APPLY F (LIST X1 X2 ... XN))
AOJA T,IAPPLY ;IN *RSET MODE, WE FAKE
ADDI T,1 ; OUT THE UUO STUFF
MOVEI TT,(P) ; INTO DOING THE APPLY
ADDI TT,(T) ; FRAME HACKERY FOR US
MOVEI B,CPOPJ
EXCH B,(TT)
JCALLF 16,(B)
;;; VERY INTERNAL APPLY, FOR USE PARTICULARLY WITH "CALL" UUO'S
;;;
;;; STATE OF WORLD AT ENTRANCE TO IAPPLY:
;;; T HAS -<NUMBER OF ARGS ON PDL>.
;;; PDL HAS ARGS ON IT; BELOW THEM IS A SLOT
;;; WITH THE FUNCTION IN THE RIGHT HALF.
;;; THE FUNCTION'S NAME IS MAYBE IN THE LEFT HALF.
;;; C IS USED PRIMARILY TO POINT TO THIS LATTER SLOT; AND, AS
;;; USUAL, THE LEFT HALF HELPS TO LIMIT FUNCTION RE-EVALS.
;;; IF THERE IS ONLY ONE ARG ON THE STACK, 400000 IN THE LEFT
;;; HALF OF THE PDL SLOT MEANS FUNCTION IS A FEXPR, AND MAY
;;; THEREFORE TAKE AN EXTRA (A-LIST) ARGUMENT.
IAPPLY: MOVE C,T ;STATE OF WORLD AT ENTRANCE:
ADDI C,(P) ; T HAS -<NUMBER OF ARGS ON PDL>
ILP1: HRRZ A,(C) ; NEXT PDL SLOT HAS FUNCTION IN RH,
SKOTT A,LS
2DIF JRST (TT),APTB1-1,QLIST ;FN IS NOT LIST STRUCTURE
HRRZ B,(A)
HLRZ A,(A)
CAIN A,QLAMBDA
JRST IAPLMB ;IT'S A LAMBDA
IFN FUNAFL,[
CAIN A,QFUNARG
JRST APFNG ;IT'S A FUNARG (MORE GOOD GRIEF!)
CAIN A,QLABEL
JRST APLBL ;IT'S A LABEL (SUPER GOOD GRIEF!)
] ;END OF IFN FUNAFL
PUSH P,C
PUSH FXP,T
HRRZ A,(C)
JUMPL C,IAP2A ;JUMP IF WE'VE RE-EVAL'ED TOO MUCH
PUSHJ P,EV0 ;ELSE EVAL THE FUNCTIONAL FORM
POP P,C ; AND TRY IT AGAIN...
POP FXP,T
ILP1B: MOVE B,(C)
HRRM A,(C)
TLNN B,-1
HRLM B,(C) ;PUTS FUNCTION NAME IN LH IF NOT THERE
TLO C,400000
JRST ILP1
APTB1: JRST IAP2A ;FIXNUMS ARE NOT FUNCTIONS!
JRST IAP2A ;NOR FLONUMS
IFN BIGNUM, JRST IAP2A ;NOR BIGNUMS ALREADY
JRST IAPATM ;SYMBOLS ARE OKAY, BUT JUST BARELY
REPEAT HNKLOG, .VALUE ;HUNKS
JRST IAP2A ;TRUE RANDOMS ARE OUT!
JRST IAPSAR ;IT'S AN ARRAY - OKAY, I GUESS
IAPATM: HRRZ B,(A) ;APPLY GOT ATOMIC FUNCTION
HRRZS 1(C) ;KILL POSSIBLE 400000 BIT DUE TO FEXPR
TDZA R,R
IAPAT2: HRRZ B,(B)
IAPAT3: JUMPE B,IAPIA1 ;GRAB FUNCTION FROM PROP LIST
HLRZ TT,(B)
HRRZ B,(B)
CAIL TT,QARRAY ;REMEMBER, FUNCTION PROPS ARE
CAILE TT,QAUTOLOAD ; LINEAR IN MEMORY
JRST IAPAT2
2DIF JRST @(TT),IATT,QARRAY
IATT: IAPARR ;ARRAY
IAPSBR ;SUBR
IAPSBR ;FSUBR
IAPLSB ;LSUBR
IAPXPR ;EXPR
IAPXPR ;FEXPR
IAPAT2 ;IGNORE MACROS
IAPIAL ;AUTOLOAD
IAPIAL: HRRI R,(B)
JRST IAPAT2
IAPIA1: JUMPL R,IAP2J
JUMPE R,IAP2
MOVEI B,(R)
MOVEI T,(A)
PUSHJ P,IIAL
HRRZ B,(A)
SETO R,
JRST IAPAT3
IIAL: PUSH P,A
HLRZ A,(B)
PUSHJ P,AUTOLOAD
JRST POPAJ
IAPSAR: SKIPA TT,A ;APPLY A SAR
IAPARR: HLRZ TT,(B) ;APPLY AN ARRAY
MOVEM TT,LISAR ;FOR INTERRUPT PROTECTION ONLY
MOVEI R,(T)
MOVEI TT,IAPAR1
JRST IAPSB1
IAPSBR: HLRZ TT,(B) ;APPLY A SUBR
HRRZ R,(C)
IAPSB1: HRRM TT,(C)
JRST ESB1
IAPAR1: MOVE TT,LISAR
JRST @ASAR(TT)
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAPLSB: MOVEI TT,CPOPJ
HRRM TT,(C)
MOVE R,B
JRST ELSB1
IAP2: JUMPL C,IAP2A
HRRZ A,(C) ;APPLY FUNCTIONAL FROM VALUE CELL
HLRZ A,(A)
HRRZ A,@(A)
CAIE A,QUNBOUND ;FOOBAR! IT'S UNBOUND
JRST ILP1B
JRST IAP2A
IAPLMB: HLRZ TT,(B) ;APPLY A LAMBDA EXPRESSION
MOVEI D,(TT)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNE D,SY
JUMPN TT,IAP3
SETZ D, ;IMPORTANT THAT D BE NON-NEG - SEE IAP4
MOVEI C,(TT)
HRRZ B,(B)
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;NO MORE ARGS
JUMPE TT,QF2A ;TOO MANY ARGS SUPPLIED
IAP5: HLRZ A,(TT)
SKIPE V.RSET
JRST IAP5B
IAP5C: MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1) ;SEE COMMENT AT EFX - ALLOWS
HRLM A,(AR1) ; A FEXPR TO TAKE AN A-LIST ARG
HRRZ TT,(TT)
AOJA T,IPLMB1
IAP5B: MOVEI D,(A)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,SY
JRST LMBERR
JRST IAP5C
IPLMB2: JUMPN TT,IAP4 ;TOO FEW ARGS SUPPLIED
JUMPN R,IPLMB4 ;NO LAMBDA LIST IN FUN
POP P,TT
HRRI TT,CPOPJ ;LAMBDA LIST IS NULL
SKIPE V.RSET
PUSH P,TT
HRRZ A,(B)
JUMPN A,LMBLP
HLRZ A,(B)
JRST EVAL
IPLMB4: MOVEM SP,SPSV
SKIPA
IPLM4A: PUSHJ P,BIND ;BIND VALUES TO LAMBDA VARS
POP P,AR1 ;FUN HAS A NON-NL LAMBDA LIST
HLRZ A,AR1
AOJLE R,IPLM4A
SKIPN V.RSET
JRST IPLMB5
HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
IPLMB5: JSP T,SPECX
HRRZ AR1,(B)
PUSH P,CUNBIND
HLRZ A,(B)
JUMPE AR1,EVAL ;A GENERALIZED LAMBDA, WITH NON-NULL LAMBDA LIST
LMBLP: PUSH P,B ;FOR GENERALIZED LAMBDAS, EVALUATES A SEQUENCE OF EXP'S
HLRZ A,(B)
PUSHJ P,EVAL
LMBLP1: POP P,B
HRRZ B,(B)
LMBLP2: JUMPN B,LMBLP
POPJ P,
IPROGN: MOVEI A,NIL ;INTERNAL PROGN
JRST LMBLP2
IAP3: MOVEI A,(TT) ;APPLY LEXPR
MOVN TT,T
CAIL TT,XHINUM
JRST LXPRLZ
MOVEI AR1,CPOPJ
HRRM AR1,(C)
MOVEI AR1,IN0(TT)
MOVEM SP,SPSV
PUSHJ P,BIND
MOVEI C,(C)
EXCH C,ARGLOC
HRLI C,ARGLOC
PUSH SP,C ;BIND ARGLOC TO LOC OF ARGS ON PDL
EXCH AR1,ARGNUM
HRLI AR1,ARGNUM
PUSH SP,AR1 ;BIND ARGNUM TO NUMBER OF ARGS
JSP T,SPECX
HRRZ B,(B)
PUSHJ P,LMBLP
SKIPN T,@ARGNUM
JRST UNBIND
HRLS T
SUB P,T
JRST UNBIND
CUNBIN: JRST UNBIND
IAP4: JUMPGE D,QF3A
AOJN R,QF3A
IFE FUNAFL, JRST QF2A
IFN FUNAFL, JRST IAP4A ;FEXPR OF TWO ARGS
SUBTTL FUNCTION, QUOTE, DECLARE, COMMENT, SETQ, AND, OR
FUNCTION: SKIPA D,CQFUNCTION ;FEXPR 1
QUOTE: MOVEI D,QQUOTE ;FEXPR 1
JUMPE A,WNAFOSE
HRRZ TT,(A)
JUMPE TT,$CAR
JRST WNAFOSE
DECLARE: MOVEI A,QDECLARE ;FSUBR (IGNORES ARG)
POPJ P,
$COMMENT: MOVEI A,Q$COMMENT ;FSUBR (IGNORES ARG)
POPJ P,
SETQ: PUSH P,A
SET1: HLRZ A,@(P)
JSP D,SETCK
HRRZ B,@(P)
JUMPE B,SETWNA
PUSH P,A ;ATOM TO BE SETQD
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,-1(P)
PUSHJ P,EVAL
POP P,AR1
JSP T,.SET
SKIPE (P)
JRST SET1
JRST POP1J
$AND: HRLI A,TRUTH
$OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,POPAJ
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST POPAJ
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
SUBTTL PROG, PROGV, RETURN, GO
PROG: HLRZ AR2A,(A) ;FSUBR
HRRZ A,(A)
PUSH P,A
SETZ C,
JSP T,PBIND ;BIND PROG VARIABLES TO NIL
POP P,A
PUSHJ P,PG0 ;EVALUATE PROG BODY
MOVEI A,NIL
JRST UNBIND ;UNBIND VARIABLES
PG0: PUSH P,PA3
PUSH P,PA4
PUSH P,SP
PUSH P,FXP
PUSH P,FLP
LPRP==.-PG0+1 ;LENGTH OF PROG PDL, IE HOW MUCH PROG HAS
MOVEM P,PA4 ;CAUSED TO BE PUSHED
HRLS A
MOVEM A,PA3
PG1: HLRZ T,PA3
PG1A: JUMPE T,PRXIT ;NORMAL EXIT
HLRZ A,(T)
HRRZ T,(T)
HRLM T,PA3
SKOTT A,LS
JRST PG1
PUSHJ P,EVAL
PG0A: JRST PG1
;;; JSP T,VBIND ;LIST OF SYMBOLS IN AR2A, VALUES IN A
;;; BINDS EACH SPECIAL VARIABLE IN THE LIST TO CORRESPODNING VALUES.
;;; IF VALUES LIST TOO SHORT, NIL GETS USED (OBVIOUSLY).
VBIND: MOVEI C,(A) ;INTERPRETED AND COMPILED PROGV COME HERE
PBIND: MOVEM SP,SPSV ;BIND PROG VARIABLES
JUMPE AR2A,SPECX
MOVEI AR1,NIL
PBIND1: HLRZ A,(AR2A) ;NEXT VARIABLE
HLRZ AR1,(C) ;NEXT VALUE
PUSHJ P,BIND ;BIND!
HRRZ C,(C)
HRRZ AR2A,(AR2A)
JUMPN AR2A,PBIND1
JRST SPECX
PROGV: HRRZ B,(A) ;FSUBR
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSH P,C
PUSH P,B
PUSHJ P,EVAL ;GET LIST OF VARIABLES
EXCH A,(P)
PUSHJ P,EVAL ;GET LIST OF VALUES
POP P,AR2A
JSP T,VBIND ;BIND VARIABLES
POP P,B
PUSHJ P,LMBLP ;EVAL REST LIKE LAMBDA BODY
JRST UNBIND
RETURN: JSP T,BKERST ;SUBR 1
MOVE P,PA4
AOS -LPRP+1(P) ;RETURN CAUSES SKIP
PRXIT: POP P,FLP ;PROG EXIT
POP P,FXP
POP P,TT
PUSHJ P,UBD0
POP P,PA4
ERRP4: POP P,PA3
RHAPJ: MOVEI A,(A)
CQFUNCTION: POPJ P,QFUNCTION
GO: JSP TT,FWNACK
FA1,,QGO
HLRZ A,(A)
GO2: JSP T,SPATOM ;LEAVES TYPE BITS IN TT
JRST GO3
GO1: JSP T,BKERST
HRRZ T,PA3
PG5: JUMPE T,EG1
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,(A)
JRST PG5A
TLNN A,400000 ;4.9 BIT => GO TAG IS NUMERIC
JRST PG5
MOVEI D,(TT)
LSH D,-SEGLOG
SKIPL D,ST(D)
TLNN D,FX+FL
JRST PG5
MOVE TT,(TT)
CAME TT,(A)
JRST PG5
PG5A: MOVE P,PA4
MOVE FLP,(P)
MOVE FXP,-1(P)
HRRZ TT,-2(P)
PUSHJ P,UBD
JRST PG1A
GO3: TLNN TT,FX+FL
JRST GO3A
GO3B: MOVE TT,(A) ;SET 4.9 BIT OF A IF TAG IS NUMERIC
CAML TT,[-XLONUM]
CAIL TT,XHINUM ; BUT NOT INUM
TLO A,400000
JRST GO1
GO3A: PUSHJ P,EVAL ;IF ARG TO GO ISN'T ATOMIC, DO ONE EVAL AND TRY AGAIN
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,FX+FL
JRST GO3B
TLNE TT,SY
JRST GO1
JRST EG1
SUBTTL DO FUNCTION
DO: PUSH P,PA4
SETZM PA4
PUSH FXP,R70 ;A "DO SWITCH" TO MARK EXPANDED FORMAT
PUSH P,A
HLRZ A,(A)
SKOTT A,LS ;HUNKS WIN AS WELL AS LISTS
JUMPN A,DO4A
HRROM A,(FXP)
HLRZ A,@(P) ;SETUP FOR MULTIPLE INDICES
HRRZ C,@(P)
HLRZ B,(C)
JRST DO4
DO4A: MOVE A,(P) ;SINGLE INDEX DO
HRRZ B,(A)
HRRZ B,(B)
HRRZ B,(B)
MOVE C,B
DO4: HRRZ C,(C)
MOVEM A,(P) ; (P) PROG BODY
DO4C: SKOTT B,LS
JUMPN B,DOERRE
PUSH P,B ; -1(P) ENDTEST
PUSH P,C ; -2(P) DO VARS LIST
MOVE A,-2(P)
MOVSI R,600000 ;EVALUATE AND SETUP INITIAL VALUES
SKIPN -1(P)
MOVSI R,400000 ;200000 BIT SAYS STEPPERS ARE OKAY
PUSHJ FXP,DO5
SKIPN -1(P)
JRST DO4D
DO7: HLRZ A,@-1(P)
PUSHJ P,EVAL
JUMPN A,DO8
DO7A: MOVE A,(P)
PUSHJ P,PG0 ;DO PROG BODY (MAY SKIP ON RETURN STATEMENT)
JRST DO2
DO9: MOVE B,-2(P)
SUB P,R70+3 ;BREAK OUT OF BODY BY RETURN STATEMENT
POP P,PA4
SUB FXP,R70+1
JUMPN B,UNBIND
POPJ P,
DO8: SKIPN A,(FXP)
JRST DO9 ;SIMPLE DO FORMAT
HRRZ B,@-1(P) ;DO PASSED ENDTEST, AND RETURNS A VALUE
PUSHJ P,IPROGN
JRST DO9
DO2: MOVE A,-2(P)
MOVEI R,0 ;DO STEPPING FUNCTIONS
PUSHJ FXP,DO5
JRST DO7
DO4D: MOVE A,(P)
PUSHJ P,PG0
SETZ A, ;DEFAULT VALUE OF ONCE-THROUGH DO IS NIL
JRST DO9
DO5: JUMPE A,DO6 ;DOES PARALLEL SETQS - ON LISTS LIKE (I V1 V2)
PUSH P,A ;WILL DO (SETQ I V1) IF R < 0
SKIPE -1(FXP) ;WILL DO (SETQ I V2) IF R > 0
HLRZ A,(A) ;IF DOSW INDICATES SINGLE INDEX, THEN ONLY ONE LIST
DO5Q: MOVEI B,(A)
JUMPGE R,DO5F
SKOTT A,LS
JRST DOERR
HLRZ A,(B)
JSP T,SPATOM
JRST DOERR
TLNE R,200000
JRST DO5F
HRRZ A,(B)
JUMPE A,DO5F
HRRZ A,(A)
JUMPN A,DO5ER
DO5F: HLRZ A,(B)
HRLM A,(P)
HRRZ A,(B)
JUMPL R,DO5E
JUMPE A,DO5B
HRRZ A,(A)
JUMPN A,DO5D
DO5B: POP P,A
SOJA R,DO5C
DO5E: JUMPE A,DO5G ;(I) IS SAME AS (I NIL) ON INITIAL VALUE
DO5D: HLRZ A,(A)
PUSH FXP,R
PUSHJ P,EVAL
POP FXP,R
DO5G: HLL A,(P)
EXCH A,(P) ;NOW (P) HAS ATOM,,VALUE
DO5C: HRRZ A,(A)
SKIPN -1(FXP)
MOVEI A,0 ;SO THAT SINGLE FORMAT DO WILL DROP OUT
AOJA R,DO5
DO6: TRNN R,-1 ;[(SETQ I V1) FROM ABOVE]
POPJ FXP, ;FIRST TIME THROUGH, WE ALLOW OLD BINDINGS
JUMPGE R,DO6C ;TO BE REMEMBERED ON THE SPDL FOR LATER UNBINDING
HRRZS R
MOVEM SP,SPSV
DO6A: POP P,AR1
HLRZ A,AR1
PUSHJ P,BIND
SOJG R,DO6A
JSP T,SPECX
POPJ FXP,
DO6C: POP P,AR1 ;DURING THE STEPPING PHASE, AS OPPOSED TO
HLRZ A,AR1 ;THE INITIALIZATION PHASE, WE LET NO BINDINGS
PUSHJ P,BIND ;ACCUMULATE ON THE SPDL
JSP T,SETXIT
SOJG R,DO6C
POPJ FXP,
SUBTTL COND, ERRSET, ERR, CATCH, THROW
COND1: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;ENTRY
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
CAIE A,TRUTH
PUSHJ P,EVAL
CON3: POP P,T
JUMPE A,COND1 ;IF FIRST OF COND PAIR IS TRUE
HLRZ T,(T)
SKIPA
COND2: POP P,T
HRRZ T,(T)
JUMPE T,CPOPJ ;LOOP FOR GENERALIZED COND PAIR
PUSH P,T
HLRZ A,(T)
PUSHJ P,EVAL
CON2: JRST COND2
BKERST: SKIPN TT,PA4
JRST BKRST1
TLZ TT,-1
SKIPE B,CATRTN
JRST BKRST2
BKRST3: SKIPE B,ERRTN
CAILE TT,(B)
JRST (T) ;NO TROUBLESOME CATCHS OR ERRSETS
BKRST4: MOVEI TT,BKERST
BKRST0: MOVEM TT,-LERSTP(B) ;BREAK UP A TROUBLESOME CATCH OR ERRSET, E.G.
MOVE P,B ;(PROG (A) (ERRSET (RETURN (FOO A))))
JRST ERR1 ;AND THEN TRY BKERST AGAIN
BKRST2: CAILE TT,(B)
JRST BKRST3 ;CATCH ISN'T TROUBLESOME, SO TEST FOR ERRSETS
JRST BKRST4 ;AH, CATCH IS TROUBLESOME!
BKRST1: MOVEI A,LGOR
%FAC EMS22
ERRSET: JSP TT,FWNACK
FA12,,QERRSET
MOVEI C,TRUTH
HRRZ B,(A)
JUMPE B,ERRST3
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI C,(A)
POP P,A
ERRST3: JSP T,ERSTP
MOVEM P,ERRTN
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
ERRNX: PUSHJ P,NCONS ;NORMAL EXIT
JRST ERUN0
ERR: JSP TT,FWNACK
FA012,,QERR
JUMPE A,ERR2
HRRZ B,(A)
JUMPE B,.+3
HLRZ B,(B)
JUMPE B,ERR3A
HLRZ A,(A) ;EVAL BEFORE UNBLOCKING
PUSHJ P,EVAL
JRST ERR2
ERR3A: SKIPN ERRTN
JRST LSPRET
MOVEI T,ERR3
EXCH T,-LERSTP(P)
JRST ERR0 ;UNBLOCK THE ERRSET, THEN
ERR3: SKIPE A ;EVAL THE ARG TO ERR
HLRZ A,(A)
PUSH P,T
JRST EVAL
CATCH: JSP TT,FWNACK
FA12,,QCATCH
PUSHJ P,CATHRO
JSP TT,CATPS1
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI B,NIL ;CAUSE MOST RECENT CATCH TO BE THROWN
JRST THROW1
THROW: JSP TT,FWNACK
FA12,,QTHROW
PUSHJ P,CATHRO
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
POP P,B
JRST THROW1
CATHRO: MOVE B,A
HRRZ A,(A)
JUMPE A,CPOPJ
HLRZ A,(A)
POPJ P,
SUBTTL STORE, BREAK, SIGNP
STORE: JSP TT,FWNACK
FA2,,QSTORE
HLRZ B,(A)
PUSH P,B
HRRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
PUSH P,A
STORE7: HRRZ A,-1(P)
SETZM LISAR
PUSHJ P,EVAL
SKIPN V.RSET ;#####HERE IS THE GLITCH FOR *RSET CHECKING ON STORE
JRST STORE9
SKIPN A,LISAR
JRST STORE5
JSP T,ARYSIZ
HLL D,ASAR(A)
TLNE D,AS<SX>
LSH F,-1
TLNN R,200000 ;=> NEGATIVE INDEX
CAIGE F,(R) ;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE
JRST STORE5
STORE9: POP P,A
SUB P,R70+1
JSP T,.STORE
SETZM LISAR
POPJ P,
BREAK: JSP TT,FWNACK ;FSUBR (1 . 2)
FA12,,QBREAK
HLRZ B,(A) ;BKPT NAME
HRRZ A,(A)
JUMPE A,$BRK0 ;NO SECOND ARG => ALWAYS BREAK
HLRZ A,(A) ;TO-BREAK-OR-NOT SWITCH
PUSH P,B
PUSHJ P,EVAL ;THIS IS A CROCK!!!
POP P,B
JRST $BREAK ;A = BREAKP, B = BREAKID
SIGNP: JSP TT,FWNACK ;FSUBR 2
FA2,,QSIGNP
PUSH P,(A)
HLRZ A,(A)
PUSH P,A
SIGNP0: PUSHJ P,PNGET
HLRZ A,(A)
MOVS T,(A)
HRRZ A,(A)
JUMPN A,SIGNPE
MOVNI A,6
CAIE T,@SPTB+6(A)
AOJL A,.-1
JUMPGE A,SIGNPE
HLLZ A,SPTB+6(A)
SUB P,R70+1
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NUMBERP
JUMPE A,POP1J
POP P,T
HRRI T,TRUE
XCT T
JRST FALSE
SPTB:
IRP Q,,[L,E,LE,G,GE,N]
JUMP!Q TT,(ASCII \Q\)
TERMIN
SUBTTL PROG2, PROGN, EQ, RPLACA, RPLACD
PROG2: MOVEI D,QPROG2
CAMLE T,XC-2
JRST WNALOSE
HRLI T,-1(T)
ADD T,P
MOVE A,2(T)
MOVEM T,P
POPJ P,
PROGN: AOJG T,FALSE
POP P,A
PROGN1: JUMPE T,CPOPJ
HRLI T,-1(T)
ADD P,T
POPJ P,
EQ: CAMN A,B ;SUBR 2 - POINTER IDENTITY PREDICATE
JRST TRUE
JRST FALSE
RPLACA: SKOTT A,LS
JRST RPLCA0
TLNE TT,PUR+VC
JRST RPLCA1
HRLM B,(A)
POPJ P,
RPLACD: ;SUBR 2 - CLOBBER CDR OF FIRST ARG WITH SECOND
SKOTT A,LS
JRST RPLCD2
TLNE TT,PUR
JRST RPLCD1
RPLCD3: HRRM B,(A)
POPJ P,
RPLCD2: JUMPE A,RPLCD0 ;(RPLACD NIL FOO) IS ALWAYS A LOSS
SKIPE T,VCDR
CAIN T,QLIST ;IF CDR = NIL OR LIST, THEN BOMBOUT
JRST RPLCD0 ;SINCE ARG IS NOT LIST OR NIL
CAIN T,QSYMBOL
TLNE TT,SY
JRST RPLCD3 ;IF NOT CDR = SYMBOL, THEN ANYTHING GOES
JRST RPLCD0
PGTOP EVL,[EVAL, APPLY, STUFF OPEN-CODED BY COMPLR]
;;@ GCBIB 122 GARBAGE COLLECTOR AND ALLOCATION STUFF
PGBOT GC
SUBTTL GRABBAGE COLLECTORS AND RELATED ITEMS
GCRET: TDZA A,A ;GC WITH NORET=NIL
GCNRT: MOVEI A,TRUTH ;GC WITH NORET=T
HRRI T,UNBIND ;EXPECTS FLAG IN LH OF T
PUSH P,T
JSP T,SPECBIND
0 A,VNORET
JRST AGC
GC: PUSH P,[333333,,FALSE] ;SUBR 0 - USER ENTRY TO GC
JRST AGC ;TO UNDERSTAND THE 3'S, SEE GSTRT7
MINCEL==3*NFF ;MIN NUMBER WORDS TO RECLAIM FOR EACH SPACE
IFG 40-MINCEL, MINCEL==40
GCCNT:
OFFSET -.
NIL ;SO THAT THE FOLLOWING INS WILL STOP ON NIL
GCCNT1: SKIPE TT,(TT)
GCCNT4: AOJA GCCNT0,.-1 ;OR MAYBE AOBJN
LPROG3==.
JRST GCP4A
GCCNT0:
OFFSET 0
.HKILL GCCNT1 GCCNT4 GCCNT0
;;; *********** GARBAGE COLLECTOR **********
SUBTTL GC - INITIALIZATION
XCTPRO
AGC4: HRROS NOQUIT
NOPRO
SUBI A,2 ;ENTRY FROM FWCONS,FPCONS
PUSH P,A
XCTPRO
AGC: HRROS NOQUIT
NOPRO
SKIPE ALGCF ;CANT SUCCESSFULLY GC WHILE IN ALLOC
JRST ALERR
AGC1: ;MUST HAVE DONE HRROS NOQUIT BEFORE COMING HERE
10% .SUSET [.RRUNT,,GCTM1]
MOVEM NACS+1,GCNASV
10$ SETZ NACS+1,
10$ RUNTIM NACS+1, ;GET RUNTIME IN MILLSECS.
10$ MOVEM NACS+1,GCTM1
MOVE NACS+1,[UUOH,,GCUUSV]
BLT NACS+1,GCUUSV+LUUSV-1 ;SAVE UUOH STUFF, IN CASE STRT IS USED
MOVE NACS+1,[NACS+2,,GCNASV+1]
BLT NACS+1,GCNASV+17-<NACS+1> ;SAVE NON-MARKED AC'S
MOVEI NACS+1,GCACSAV
BLT NACS+1,GCACSAV+NACS ;BLT AWAY ARG ACS (AND NIL) INTO PROTECTED PLACE
Q$ SETZM GCFXP
SETZ R,
REPEAT NFF,[
SKIPN FFS+.RPCNT ;FIGURE OUT WHICH SPACE(S) EMPTY
TLO R,400000←-.RPCNT
] ;END OF REPEAT NFF
SKIPN FFY2 ;IF WE RAN OUT OF SYMBOL BLOCKS,
TLO R,400000←<-FFY+FFS> ; THEN CREDIT IT TO SYMBOLS
MOVN D,R ;THIS IS A STANDARD HACK TO KILL ONE BIT
TDZE R,D ;SKIP IF THERE WERE NO BITS
JUMPE R,GCGRAB ;JUMP IF EXACTLY ONE BIT ON
AGC1Q: SETZM GCRMV
AOSE IRMVF ;IF OVERRIDE IS ON, THEN
SKIPE VGCTWA
SETOM GCRMV ;DO REMOVAL ANYHOW.
MOVNI TT,20 ;TOP 40 BITS OF WORD ON
JSP F,GCINBT ;INIT MARK BITS FOR LIST, FIXNUM, ETC.
GCINB5: MOVE T,VGCDAEMON
IOR T,GCGAGV
JUMPE T,GCP6
MOVSI R,GCCNT
BLT R,LPROG3
SKIPN VGCDAEMON
HRLI GCCNT4,(AOBJN GCCNT0,)
MOVNI R,NFF ;MAY OR MAY NOT HAVE BIGNUMS OR HUNKS
GCP4: SETZ GCCNT0,
SKIPGE FFS+NFF(R)
JRST GCP4B
SKIPN VGCDAEMON
MOVSI GCCNT0,-MINCEL
SKIPE TT,FFS+NFF(R)
AOJA GCCNT0,GCCNT1
GCP4A: TLZ GCCNT0,-1
HRRZ F,GCWORN+NFF(R) ;ACCOUNT FOR LENGTHS OF ITEMS
IMULI GCCNT0,(F)
CAIGE GCCNT0,MINCEL
SETZM FFS+NFF(R)
GCP4B: HRLM GCCNT0,NFFS+NFF(R)
AOJL R,GCP4
;FALLS THROUGH
;FALLS IN
;;; PDLS ARE SAFE
WHL==USELESS*QIO*ITS
IFN WHL,[
MOVE F,GCWHO
SKIPE GCGAGV
JRST GSTRT0
TRNN F,1
JRST GCP6
JRST GSTR0A
] ;END OF IFN WHL
.ELSE,[
SKIPN GCGAGV
JRST GCP6
] ;END OF .ELSE
GSTRT0: STRT 17,[SIXBIT \↑M;GC DUE TO !\]
GSTR0A: SETZB TT,D ;FIGURE OUT REASON FOR GC
HLRZ T,(P)
CAIN T,111111 ;WAS IT INITIAL STARTUP? (SEE LISP)
MOVEI TT,[SIXBIT \STARTUP!\]
CAIN T,333333 ;WAS IT USER CALLING GC FUNCTION?
MOVEI TT,[SIXBIT \USER!\]
CAIN T,444444 ;WAS IT ARRAYS?
MOVEI TT,[SIXBIT \ARRAY RELOCATION!\]
Q$ CAIN T,555555 ;I/O CHANNELS?
Q$ MOVEI TT,[SIXBIT \I/O CHANNELS!\]
JUMPN TT,GSTRT8
MOVNI T,NFF ;NONE OF THOSE HYPOTHESES WORK
GSTRT1: SKIPN FFS+NFF(T) ;MAYBE SOME STORAGE SPACE RAN OUT
SKIPA TT,T
ADDI D,1
AOJL T,GSTRT1
JUMPE TT,GSTRT7 ;NO, THAT WASN'T IT
IFN WHL, SKIPN GCGAGV
.ALSO, JRST GSTRT6
MOVNI T,NFF ;YES, IT WAS. PRINT MOBY MESSAGE!
SETZ R,
GSTRT2: SKIPE FFS+NFF(T)
JRST GSTRT5
JUMPE R,GSTRT3
CAIE D,NFF-2
STRT 17,[SIXBIT \, !\]
CAMN T,TT
STRT 17,[SIXBIT \ AND !\]
GSTRT3: SETO R,
STRT 17,@GSTRT9+NFF(T)
GSTRT5: AOJL T,GSTRT2
STRT 17,[SIXBIT \ SPACE!\]
CAIE D,NFF-1
STRT 17,[SIXBIT \S!\]
IFN WHL, MOVE TT,GSTRT9+NFF(TT)
JRST GSTRT6
GSTRT7: MOVEI TT,[SIXBIT \ ? !\] ;I DON'T KNOW WHY WE'RE HERE!
GSTRT8:
IFN WHL,SKIPE GCGAGV
STRT 17,(TT) ;PRINT REASON
GSTRT6:
IFN WHL,[
TRNN F,1
JRST GCWHL9
MOVE D,(TT)
MOVE R,1(TT)
ROTC D,-22
MOVSI F,(SIXBIT \!\)
MOVE T,[220600,,D]
GCWHL2: ILDB TT,T
CAIE TT,'!
JRST GCWHL2
GCWHL3: DPB NIL,T
IBP T
TLNE T,770000
JRST GCWHL3
HRLI D,(SIXBIT \GC:\)
MOVE T,[-6,,GCWHL6]
.SUSET T
MOVEI T,40
.SUPSET T,
GCWHL9:
] ;IFN WHL
;FALLS THROUGH
;;; PDLS ARE SAFE
SUBTTL GC - MARK THE WORLD
;FALLS IN
GCP6: HRROS MUNGP ;STARTING TO MUNG SYMBOL/SAR MARK BITS
MOVE A,[<-20>←-NUNMRK] ;PRE-PROTECT CERTAIN
ANDM A,BTBLKS ; RANDOM LIST CELLS
MOVNI R,NACS+1 ;PROTECT CONTENTS OF MARKED ACS
GCP6Q0: HRRZ A,GCACSAV+NACS+1(R)
JSP T,GCMARK
AOJL R,GCP6Q0
HRRZ R,C2
ADDI R,1
GCP6Q1: HRRZ A,(R) ;CAUSES MARKING OF CONTENTS
JSP T,GCMARK ;OF ACS AT TIME OF GC, AND OF REG PDL
CAIGE R,(P)
AOJA R,GCP6Q1
MOVEI R,LPROTE-1
GCP6Q2: MOVEI A,BPROTE(R) ;PROTECT PRECIOUS STUFF
JSP T,GCMARK
SOJGE R,GCP6Q2
IFN BIGNUM,[
MOVEI R,LBIGPRO-1
GCP6Q3: MOVEI A,BBIGPRO(R)
JSP T,GCMARK
SOJGE R,GCP6Q3
] ;END OF IFN BIGNUM
MOVSI R,TTS<GC>
IORM R,DEDSAR+TTSAR ;PROTECT DEDSAR
IORM R,UB.AC+TTSAR ;PROTECT "UNBOUND" ARRAY SAR
IORM R,DBM+TTSAR ;PROTECT DEAD BLOCK MARKER
HRRZ R,SC2
GCP6Q4: HRRZ A,(R)
JSP T,GCMARK ;MARK SAVED VALUES ON SPEC PDL
CAIGE R,(SP)
AOJA R,GCP6Q4
SKIPN R,INTAR
JRST GCP6Q6
GCP6Q5: MOVE A,INTAR(R)
JSP T,GCMARK
SOJG R,GCP6Q5
GCP6Q6: ;PROTECT INTERRUPT FUNCTIONS
IFE QIO,[
MOVEI R,LUINTTB-1
GCP6Q7: SKIPE A,@UINTTB(R)
JSP T,GCMARK
SOJGE R,GCP6Q7
] ;END OF IFE QIO
IFN QIO,[
IRP Z,,[0,1,2]X,,[ALARMCLOCK,AUTFN,UDF]
MOVEI R,NUINT!Z
SKIPE A,V!X(R)
JSP T,GCMARK
SOJG R,.-2
TERMIN
SKIPE A,VMERR
JSP T,GCMARK
] ;END OF IFN QIO
SKIPN GCRMV
JRST GCP6B1
JSP R,GCGEN ;IF DOING TWA REMOVAL, TRY MARKING FROM
GCP8I ;NON-TRIVIAL P-LISTS OF CURRENT OBARRAY
JRST GCP6B2
;;; PDLS ARE SAFE
GCP6B1: MOVE A,VOBARRAY
JSP TT,$GCMKAR ;OTHERWISE, JUST MARK OBARRAY BUCKETS
GCP6B2: MOVEI A,OBARRAY
CAME A,VOBARRAY
JSP TT,$GCMKAR
MOVE R,GCMKL
GCP6A: JUMPE R,GCP6D
HLRZ A,(R)
MOVE D,ASAR(A)
TLNN D,AS<GCP> ;IF ARRAY POINTER HAS "GC ME" BIT SET,
JRST GCP6F
TLNE D,AS<OBA> ;MORE CHECKING ON OBARRAYS
JRST GCP6F0
GCP6F1: JSP TT,GCMKAR ; THEN MARK FROM ARRAY ENTRIES
GCP6F: HRRZ R,(R)
HRRZ R,(R)
JRST GCP6A
GCP6F0: CAMN A,VOBARRAY ; AND IF THIS ISN'T THE CURRENT OBARRAY,
SKIPN GCRMV ; OR IT IS, BUT WE ARENT DOING GCTWA REMOVAL,
JRST GCP6F1
JRST GCP6F
GCP6D:
IFN QIO,[
MOVE A,V%TYI
JSP TT,$GCMKAR
MOVE A,V%TYO
JSP TT,$GCMKAR
] ;END OF IFN QIO
SKIPN R,PROLIS
GCP6D1: JUMPE R,GCP6H ;PROTECT READ-MACRO
HLRZ A,(R) ; FUNCTIONS (CAN'T JUST GCMARK WHOLE
HLRZ A,(A) ; PROLIS - DON'T WANT TO PROTECT
JSP T,GCMARK ; READTABLE SARS)
HRRZ R,(R)
JRST GCP6D1
GSTRT9: [SIXBIT \LIST!\] ;ALSO USED BY GCWORRY
[SIXBIT \FIXNUM!\]
[SIXBIT \FLONUM!\]
IFN BIGNUM, [SIXBIT \BIGNUM!\]
[SIXBIT \SYMBOL!\]
IRP X,,[4,8,16,32,64,128,256,512,1024]
IFE .IRPCNT-HNKLOG, .ISTOP
[SIXBIT \HUNK!X!!\]
TERMIN
[SIXBIT \ARRAY!\]
IFN WHL,[
GCWHL6: .RWHO1,,GCWHO1
.RWHO2,,GCWHO2
.RWHO3,,GCWHO3
.SWHO1,,[.BYTE 8?66?0?366?0?.BYTE]
.SWHO2,,D
.SWHO3,,R
] ;IFN WHL
;;; PDLS ARE SAFE
SUBTTL GC - CONSIDER THE EFFECTS OF AN ARRAY DISAPPEARING
;;; UPDATE THE GCMKL BY SPLICING OUT ARRAYS TO BE SWEPT.
;;; IF ANY SUCH ARRAYS ARE OPEN FILES, CLOSE THEM.
CGCMKL:
GCP6H: SKIPN F,GCMKL
JRST GCP7
JSP A,GCP6H0
GCP6H1: HLRZ A,(F)
TDNE TT,TTSAR(A)
JRST GCP6G
Q$ TDNE T,ASAR(A)
Q$ JRST GCP6H7
Q$ GCP6H8:
ANDCAM TT,TTSAR(A)
IORM R,TTSAR(A)
MOVEI B,ADEAD
EXCH B,ASAR(A)
TLNN B,AS<RDT>
JRST GCP6G
MOVEI AR1,PROLIS ;JUST KILLED A READTABLE
GCP6H3: HRRZ AR2A,(AR1) ; - CLEAN UP PROLIS
GCP6H4: JUMPE AR2A,GCP6G
HLRZ C,(AR2A)
HRRZ C,(C)
HLRZ C,(C)
CAIE C,(A)
JRST GCP6H5
HRRZ AR2A,(AR2A)
HRRM AR2A,(AR1)
JRST GCP6H4
GCP6H5: MOVEI AR1,(AR2A)
JRST GCP6H3
GCP6G: HRRZ F,(F)
HRRZ F,(F)
JUMPN F,GCP6H1
JRST GCP7
GCP6H0: MOVSI T,AS<JOB+FIL> ;SET UP SOME ACS FOR THE GCMKL-LOOK LOOP
MOVE R,[TTDEAD]
MOVSI TT,TTS<CN+GC>
JRST (A)
;;; PDLS ARE SAFE
IFN QIO,[
;;; CLEAN UP AND CLOSE A FILE WHEN GARBAGE COLLECTED
GCP6H7: MOVE B,TTSAR(A) ;ABOUT TO GC A FILE ARRAY
TLNE B,TTS<CL> ;IGNORE IF ALREADY CLOSED
JRST GCP6H8
PUSH P,F
IFN JOBQIO,[
HLL B,ASAR(A)
TLNE B,AS<JOB>
JRST GCP6J1
] ;END OF IFN JOBQIO
PUSHJ P,ICLOSE ;OTHERWISE CLOSE THE FILE
MOVEI R,[SIXBIT \↑M;FILE CLOSED: !\]
GCP6H2: SKIPN GCGAGV
JRST GCP6H9
STRT 17,(R)
HLRZ A,@(P)
HRRZ AR1,VMSGFILES
TLO AR1,200000
HRROI R,$TYO
PUSHJ P,PRINTA
GCP6H9: POP P,F
JSP A,GCP6H0 ;RE-INIT MAGIC CONSTANTS IN ACS
HLRZ A,(F)
JRST GCP6H8
IFN JOBQIO,[
;;; CLEAN UP AND CLOSE AN INFERIOR PROCEDURE WHEN GARBAGE COLLECTED
GCP6J1: MOVEI R,[SIXBIT \↑M;FOREIGN JOB FLUSHED: !\]
SKIPN T,J.INTB(B)
JRST GCP6J3
MOVEI R,[SIXBIT \↑M;INFERIOR JOB FLUSHED: !\]
.CALL GCP6J9
.VALUE
.UCLOSE TMPC,
JFFO T,.+1
MOVNS TT
SETZM JOBTB+21(TT)
GCP6J3: MOVSI T,TTS<CL>
ANDCAM T,TTSAR(A)
JRST GCP6H2
GCP6J9: SETZ
SIXBIT \OPEN\ ;OPEN FILE (INFERIOR PROCEDURE)
1000,,TMPC ;CHANNEL NUMBER
,,F.DEV(B) ;DEVICE NAME (USR)
,,F.FN1(B) ;FILE NAME 1 (UNAME)
400000,,F.FN2(B) ;FILE NAME 2 (JNAME)
] ;END OF IFN JOBQIO
] ;END OF IFN QIO
;;; PDLS ARE SAFE
SUBTTL GC - TWA REMOVAL
GCP7: HRRZ A,GCMKL
JSP T,GCMARK
HRRZ A,PROLIS
JSP T,GCMARK
SKIPN GCRMV
JRST GCSWP
JSP R,GCGEN ;IF DOING TWA REMOVAL, THEN WIPE OUT
GCP8G ; T.W.A.'S AND THEN MARK BUCKETS
MOVE A,VOBARRAY
JSP TT,$GCMKAR
;FALLS THROUGH
;;; PDLS ARE UNSAFE
SUBTTL GC - SWEEP THE WORLD
;FALLS IN
GCSWP: .SEE KLINIT ;WHICH CLOBBERS NEXT INSTRUCTION
Q$ MOVEM FXP,GCFXP
MOVSI FXP,GCFSSWP ;RELOCATE INNER LOOP TO AC'S.
BLT FXP,LPROG1 ;FOR FS SWEEP.
MOVNI SP,3+BIGNUM ;SWEEP UP THREE OR FOUR FREELISTS
MOVEM SP,GC99
GCSWP1: TRZ GFSCNT,-1 ;ZERO COUNT FOR THIS LIST
SETZ P, ;FREELIST ENDS IN NIL
SKIPN SP,FSSGLK+3+BIGNUM(SP) ;GET PAGE # OF FIRST PAGE OF THIS TYPE
JRST GCSWP4
GCSWP2: MOVEM SP,GC98
MOVE FLP,GCST(SP) ;GET ADDRESS OF BIT TABLE
LSH FLP,SEGLOG-5 ;LSH TO PROPER PLACE
HRLI FLP,-BTBSIZ ;<BTBSIZ> WORDS OF BITS
LSH SP,SEGLOG ;GET ACTUAL PAGE ADDRESS
HRLI SP,-40 ;40 CELLS PER BIT WORD
JRST GFSP1 ;***SWEEP!***
GCSWP3: MOVE SP,GC98
LDB SP,[SEGBYT,,GCST(SP)] ;FIND PAGE # OF NEXT PAGE
JUMPN SP,GCSWP2 ;JUMP UNLESS NO MORE
GCSWP4: AOS SP,GC99
MOVEM P,FFS+3+BIGNUM-1(SP) ;SAVE FREE LIST
HRRM GFSCNT,NFFS+3+BIGNUM-1(SP) ;SAVE COUNT OF CELLS RECLAIMED
JUMPL SP,GCSWP1 ;GO DO NEXT KIND OF SPACE IF ANY
GCSW4A: MOVSI SP,GSYMSWP ;SYMBOL SPACE HAS A SPECIAL SWEEPER
BLT SP,LPROG6
MOVE SP,SYSGLK
GCSWP6: JUMPE SP,GCSWP7
MOVEI FLP,(SP)
LSH FLP,SEGLOG
HRLI FLP,-SEGSIZ
LDB SP,[SEGBYT,,GCST(SP)]
JRST GYSP1
GCSWP7: HRRZM GYSP8,FFY
HRRM GYCNT,NFFY
IFN HNKLOG,[
MOVSI SP,GHNKSWP ;HUNK SWEEPER
BLT SP,LPROGH
MOVEI SP,HNKLOG
MOVEM SP,GC99 ;GC99 COUNTS VARIOUS HUNK SIZES
GCSWH1: TRZ GHCNT,-1 ;CLEAR COUNT OF HUNKS
SETZ P, ;CLEAR FREELIST
SKIPN SP,HNSGLK-1(SP)
JRST GCSWH4
MOVEI FXP,1 ;CALCULATE VARIOUS PARAMETERS
LSH FXP,@GC99 ; FOR SWEEPER
HRRI GHSP4,(FXP) .SEE GHNKSWP
SUBI FXP,1
HRRI GHSP5,(FXP)
LSH FXP,-5
HRRI GHSP7,(FXP)
MOVN FLP,GC99
MOVNI FXP,40
LSH FXP,(FLP)
HRRI GHSP6,(FXP)
GCSWH2: MOVEM SP,GC98
MOVE FLP,GCST(SP) ;SET UP AOBJN POINTER TO BIT BLOCKS
LSH FLP,SEGLOG-5
HRLI FLP,-BTBSIZ
LSH SP,SEGLOG ;SET UP AOBJN POINTER TO SWEEP SPACE
HRLI SP,(GHSP6)
JRST GHSP1 ;***** SWEEP! *****
GCSWH3: MOVE SP,GC98
LDB SP,[SEGBYT,,GCST(SP)]
JUMPN SP,GCSWH2 ;MAYBE HACK NEXT SEGMENT OF SAME SIZE HUNKS
GCSWH4: SOS SP,GC99
HRRM P,FFH-1+1(SP) ;DON'T DISTURB FFH SIGN BIT!
MOVEI P,(GHCNT)
LSH P,1(SP) ;ACCOUNT FOR SIZE OF HUNKS
HRRM P,NFFH-1+1(SP)
JUMPG SP,GCSWH1
] ;END OF IFN HNKLOG
MOVSI SP,GSARSWP ;SAR SPACE HAS A SPECIAL SWEEPER
BLT SP,LPROG4
MOVE SP,SASGLK
GCSWP8: JUMPE SP,GCSWP9
MOVEI FXP,(SP)
LSH FXP,SEGLOG
HRLI FXP,-SEGSIZ/2
LDB SP,[SEGBYT,,GCST(SP)]
JRST GSSP1
GCSWP9: HRRZM GSSP9,FFA
LSH GSCNT,1 ;ACCOUNT FOR SIZE OF SARS
HRRM GSCNT,NFFA
HRRZS MUNGP
MOVSI F,TTS<CN+GC>
ANDCAM F,DEDSAR ;MUST CLEAR BITS IN DEDSAR
JSP T,GCACR
;FALLS THROUGH
;;; PDLS ARE SAFE
SUBTTL GC - MAKE SURE ENOUGH WAS RECLAIMED
;FALLS IN
SKIPN GCGAGV
JRST GCE0
SETZM GC99 ;GC99 COUNTS ENTRIES PRINTED
MOVNI F,NFF
GCPNT1: HRRZ T,NFFS+NFF(F)
SKIPN TT,SFSSIZ+NFF(F)
JRST GCPNT6
SOSLE GC99
JRST GCPNT2
STRT 17,[SIXBIT \↑M; !\] ;TERPRI-; EVERY THIRD ONE
MOVEI D,3
MOVEM D,GC99
GCPNT2: PUSHJ P,STGPNT
STRT 17,@GCPNT9+NFF(F)
GCPNT6: AOJL F,GCPNT1
;FALLS THROUGH
;;; PDLS ARE SAFE
SUBTTL GC - CLEANUP AND TERMINATION
;FALLS IN
GCE0: MOVNI F,NFF
GCE0C0: MOVE AR2A,MFFS+NFF(F)
TLNN AR2A,-1
JRST GCE0C1
HRRZ AR1,SFSSIZ+NFF(F)
FSC AR1,233 ;FIXNUM TO FLONUM CONVERSION
FMPR AR1,AR2A
MULI AR1,400 ;FLONUM TO FIXNUM CONVERSION
ASH AR2A,-243(AR1)
GCE0C1: SKIPGE FFS+NFF(F)
JRST GCE0C5
CAIGE AR2A,MINCEL
MOVEI AR2A,MINCEL ;MUST SATISFY ABSOLUTE MIN OF<MINCEL> CELLS
GCE0C5: MOVEM AR2A,ZFFS+NFF(F)
HRRZ TT,NFFS+NFF(F)
CAIGE TT,(AR2A) ;ALSO MUST SATISFY USER'S MIN
PUSHJ P,GCWORRY ;IF NOT, MUST WORRY ABOUT IT
GCE0C2: AOJL F,GCE0C0
MOVEI AR2A,1
SKIPN FFY2
PUSHJ P,GRABWORRY ;REMEMBER, F IS ZERO HERE
SKIPN FFY2
JRST GCLUZ
MOVNI F,NFF ;IF WE RECLAIMED LESS THAN ABSOLUTE
GCE0C3: HRRZ TT,NFFS+NFF(F) ; MINIMUM FOR ANY SPACE,
SKIPGE FFS+NFF(F)
JRST GCE0C9
CAIGE TT,MINCEL ; WE ARE OFFICIALLY DEAD
JRST GCLUZ
GCE0C9: AOJL F,GCE0C3
SKIPE PANICP
JRST GCE0C7
MOVNI F,NFF ;NOW SEE IF WE EXCEEDED MAXIMUM
GCE0C6: MOVE TT,SFSSIZ+NFF(F)
CAMLE TT,XFFS+NFF(F)
JRST GCXLOSE
AOJL F,GCE0C6
GCE0C7: MOVNI F,NFF
GCE0C4: HRRZ T,NFFS+NFF(F)
CAMGE T,ZFFS+NFF(F)
JRST GCMLOSE
AOJL F,GCE0C4
IFE D10,[
HRRZ TT,NOQUIT
IOR TT,INHIBIT
IOR TT,VNORET
SKIPN TT
PUSHJ P,RETSP
] ;END OF IFE D10
;FALLS THROUGH
;;; PDLS ARE SAFE
;FALLS IN
SKIPN VGCDAEMON
JRST GCEND
MOVEI C,NIL
MOVEI D,NFF-1
SETZ C, ;CONS UP ARG FOR GCDAEMON
GCE0E: HRRZ TT,NFFS(D)
CAIG D,1 ;ALLOW FOR SPACE USED
SUBI TT,2*NFF ; TO CONS UP THE ARG
JUMPN D,.+2
SUBI TT,NFF
JSP T,FXCONS
MOVE B,A
HLRZ TT,NFFS(D)
JSP T,FXCONS
PUSHJ P,CONS ;WE CHECKED LENGTH OF FREELISTS SO
HRRZ B,GCMES(D) ; WE KNOW CONSES WON'T RE-INVOKE GC
PUSHJ P,XCONS
MOVE B,C
PUSHJ P,CONS
MOVE C,A
SOJGE D,GCE0E
JSR GCRSR .SEE GCRSR0
IFE QIO,[
HRLI A,20. ;INT NUMBER OF GC-DAEMON
GCE0B: PUSH P,A ;FOR GC PROTECTION ONLY
MOVSS A
PUSHJ P,UINT
JRST S1PAJ
] ;END OF IFE QIO
IFN QIO,[
HRLI A,1003 ;GC-DAEMON
GCE0B: PUSH P,A ;FOR INTERRUPT PROTECTION ONLY
PUSH FXP,D
MOVS D,A
PUSHJ P,UINT
POP FXP,D
JRST S1PAJ
] ;END OF IFN QIO
GCXLOSE: MOVEM TT,XFFS+NFF(F) ;UPDATE GCMAX TO AGREE WITH GCSIZE
HRRZ C,GCMES+NFF(F) ;GIVE OUT A GC-OVERFLOW INTERRUPT
JSR GCRSR
Q% HRLI A,13. ;INT NUMBER OF GC-OVERFLOW
Q$ HRLI A,1004 ;GC-OVERFLOW
JRST GCE0B
GCPNT9: [SIXBIT \LIST, !\]
[SIXBIT \FIXNUM, !\]
[SIXBIT \FLONUM, !\]
BG$ [SIXBIT \BIGNUM, !\]
[SIXBIT \SYMBOL, !\]
IRP X,,[4,8,16,32,64,128,256,512,1024]
IFE .IRPCNT-HNKLOG, .ISTOP
[SIXBIT \HUNK!X, !\]
TERMIN
[SIXBIT \ARRAY WORDS FREE↑M!\]
;;; GC MUST EITHER JRST TO GCEND, OR JSR TO GCRSR BEFORE EXITING.
;;; THIS ASSURES THAT GCTIM WILL PROPERLY REFLECT TIME SPENT IN GC.
GCEND: JSP NACS+1,GCACR
Q$ SETZM GCFXP
10% .SUSET [.RRUNT,,NACS+1]
10$ SETZ NACS+1,
10$ RUNTIM NACS+1,
IFN WHL, MOVEM NACS+1,GC98
SUB NACS+1,GCTM1
ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME)
IFN WHL,[
SKIPE NACS+1,GCWHO
PUSHJ P,GCWHR
] ;IFN WHL
MOVE NACS+1,GCNASV
HRRZS NOQUIT
JRST CHECKI
;GCRSR: 0
GCRSR0: HRLM C,NOQUIT ;RESTORE ACS, AND CHECK FOR ANY
JSP NACS+1,GCACR ;DELAYED INTERRUPTS
Q$ SETZM GCFXP
10% .SUSET [.RRUNT,,NACS+1]
10$ SETZ NACS+1,
10$ RUNTIM NACS+1,
IFN WHL, MOVEM NACS+1,GC98
SUB NACS+1,GCTM1
ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME)
IFN WHL,[
SKIPE NACS+1,GCWHO
PUSHJ P,GCWHR
] ;IFN WHL
MOVE NACS+1,GCNASV
PUSH P,A
HLRZ A,NOQUIT
PUSH P,GCRSR
HRRZS NOQUIT
JRST CHECKI
;;; ROUTINE TO INIT MARK BITS FOR LIST, FIXNUM, FLONUM, HUNK,
;;; AND BIGNUM SPACES. INIT BITS IN TT, RETURN ADDRESS IN F.
GCINBT: MOVEM TT,BBITSG
MOVE AR2A,[BBITSG,,BBITSG+1]
BLT AR2A,@MAINBITBLT ;BLT OUT MAIN BIT AREA
MOVE A,BTSGLK ;INITIALIZE ALL BIT BLOCKS
GCINB0: JUMPE A,(F)
MOVEI AR2A,(A)
LSH AR2A,SEGLOG ;GET ADDRESS OF SEGMENT
HRLI AR2A,(AR2A)
MOVEM TT,(AR2A)
AOJ AR2A,
MOVE T,GCST(A) ;GET END ADDRESS FOR BLT
LSH T,SEGLOG-5
TLZ T,-1
CAIE T,(AR2A)
BLT AR2A,-1(T) ;***BLT!***
LDB A,[SEGBYT,,GCST(A)]
JRST GCINB0
IFN WHL,[
GCWHR: TRNN NACS+1,2
JRST GCWHR2
MOVE NACS+2,GCTIM
IDIVI NACS+2,25000./4
MOVEM NACS+2,GCWHO2
MOVE NACS+2,GC98
IMULI NACS+2,100.
IDIV NACS+2,GCTIM
HRLM NACS+2,GCWHO2
TRNE NACS+1,1
JRST GCWHR2
.SUSET [.SWHO2,,GCWHO2]
GCWHR8: MOVE NACS+2,GCNASV+1
MOVE NACS+3,GCNASV+2
POPJ P,
GCWHR2: MOVE NACS+2,[-3,,GCWHR9]
.SUSET NACS+2
MOVEI NACS+2,40
.SUPSET NACS+2,
JRST GCWHR8
GCWHR9: .SWHO1,,GCWHO1
.SWHO2,,GCWHO2
.SWHO3,,GCWHO3
] ;IFN WHL
SUBTTL MISCELLANEOUS GC UTILITY ROUTINES
GCACR:
Q$ SKIPN GCFXP
Q$ MOVEM FXP,GCFXP
MOVE NIL,[GCACSAV+1,,1] ;RESTORE ALL ACS EXCEPT NACS+1
BLT NIL,NACS
MOVE NIL,[GCNASV+1,,NACS+2]
BLT NIL,17
MOVE NIL,GCACSAV
Q$ SETZM GCFXP .SEE CHNINT ;ETC.
JRST (NACS+1)
$GCMKAR: MOVE D,ASAR(A)
GCMKAR:
Q$ MOVE F,TTSAR(A)
SKIPL D,-1(D) ;MARK FROM ARRAY ENTRIES.
JRST (TT)
GCMKA1: HLRZ A,(D)
JSP T,GCMARK
HRRZ A,(D)
JSP T,GCMARK
AOBJN D,GCMKA1
Q% JRST (TT)
IFN QIO,[
JUMPE F,(TT)
TLNE F,TTS<TY>
TLNE F,TTS<IO>
JRST (TT)
MOVEI D,FB.BUF(F) ;FOR TTY INPUT FILE ARRAYS,
HRLI D,-NASCII/2 ; MUST MARK INTERRUPT FUNCTIONS
SETZ F,
JRST GCMKA1
] ;END OF IFN QIO
;;; GCGEN GENERATES NON-NULL BUCKETS OF THE CURRENT OBARRAY
;;; AND APPLIES A GIVEN FUNCTION TO THEM. IT IS CALLED AS
;;; JSP R,GCGEN
;;; FOO
;;; GCGEN WILL EFFECTIVELY DO A JRST FOO MANY TIMES,
;;; PASSING SOME NON-NULL OBARRAY BUCKET THROUGH ACCUMULATOR D.
;;; FOO IS EXPECTED TO RETURN BY DOING A JRST GCP8A.
;;; WHEN DONE, GCGEN RETURNS, SKIPPING OVER THE ADDRESS FOO.
GCGEN: MOVE F,@VOBARRAY .SEE ASAR
MOVE F,-1(F)
SUB F,R70+1
TLZ R,400000
GCP8A: TLCE R,400000
JRST GCP8A1
AOBJP F,1(R) ;EXIT
HLRZ D,(F)
JUMPN D,@(R)
JRST GCP8A
GCP8A1: HRRZ D,(F)
JUMPN D,@(R)
JRST GCP8A
GSARSWP: ;SPECIAL SWEEPER FOR SARS
OFFSET -.
GSSP0: ADDI FXP,1
GSSP1: TDNN GSSP8,TTSAR(FXP) ;TEST IF SAR MARKED
AOJA GSCNT,GSSP2 ;NO, COUNT IT AS SWEPT
ANDCAM GSSP7,TTSAR(FXP) ;YES, TURN OFF MARK BIT
AOBJN FXP,GSSP0 ; AND TRY NEXT ONE
JRST GCSWP8
GSSP2: HRRZM GSSP9,ASAR(FXP) ;CHAIN INTO FREE LIST
HRRZI GSSP9,ASAR(FXP)
AOBJN FXP,GSSP0
JRST GCSWP8
GSSP7: TTS<GC>,,
GSSP8: TTS<CN+GC>,,
GSSP9: NIL
GSCNT: 0
LPROG4==.-1
OFFSET 0
.HKILL GSSP0 GSSP1 GSSP2 GSSP7 GSSP8 GSSP9 GSCNT
GCFSSWP: ;FS SWEEPER, RELOCATED TO ACS
OFFSET -.
GFSP1: SKIPN FXP,(FLP) ;GET A WORD OF MARK BITS
JRST GFSP5 ;IF ALL 40 WORDS MARKED, THIS SAVES TIME
GFSP2: JUMPGE FXP,GFSP4 ;JUMP IF SINGLE WORD MARKED
HRRZM P,(SP) ;ELSE CHAIN INTO FREE LIST
HRRZI P,(SP)
GFSCNT: AOJ .,0 ;RH COUNTS RECLAIMED CELLS
GFSP4: ROT FXP,1 ;ROTATE NEXT MARK BIT UP
AOBJN SP,GFSP2 ;COUNT OFF 40 WORDS
TLOA SP,-40 ;RESET 40-WORD COUNT IN AOBJN POINTER
GFSP5: ADDI SP,40 ;SKIP OVER 40 WORDS IN SWEEP
AOBJN FLP,GFSP1 ;<BTBSIZ> BLOCKS OF 40 WORDS
JRST GCSWP3
LPROG1==.-1
OFFSET 0
.HKILL GFSP1 GFSP2 GFSCNT GFSP4 GFSP5
IFN HNKLOG,[
GHNKSWP:
OFFSET -.
GHSP1: MOVE FXP,(FLP)
GHSP2: JUMPGE FXP,GHSP4
HRRZM P,(SP)
HRRZI P,(SP)
GHCNT: AOJ .,0
GHSP4: ROT FXP,1←HNKLOG
GHSP5: ADDI SP,<1←HNKLOG>-1
AOBJN SP,GHSP2
GHSP6: TLO SP,<-40>←-HNKLOG
GHSP7: ADDI FLP,<<1←HNKLOG>-1>←-5
AOBJN FLP,GHSP1
JRST GCSWH3
LPROGH==.-1
OFFSET 0
.HKILL GHSP1 GHSP2 GHCNT GHSP4 GHSP5 GHSP6 GHSP7
] ;END OF IFN HNKLOG
GSYMSWP: ;SWEEPER FOR SYMBOL SPACE
OFFSET -.
GYSP8: NIL ;LH ALWAYS ZERO (CONSIDER SWEEPING AN ALREADY FREE CELL)
GYSP1: HLRZ FXP,(FLP)
TRZN FXP,1
TDNE GYSP7,(FXP)
JRST GYSP3
JUMPN FXP,GYSP5
GYSP2: HRRZM GYSP8,(FLP)
HRRZI GYSP8,(FLP)
GYCNT: AOJ .,0
GYSP3: HRLM FXP,(FLP)
AOBJN FLP,GYSP1
JRST GCSWP6
GYSP7: 300,,0 ;3.8=PURE, 3.7=COMPILED CODE REFS
LPROG6==.-1
OFFSET 0
.HKILL GYSP1 GYSP2 GYSP3 GYSP7 GYSP8 GYCNT
;;; PART OF SYMBOL SWEEPER - RESTORES A SYMBOL BLOCK TO FFY2.
;;; ALSO ATTEMPTS TO RETURN THE VALUE CELL IF IT HAS ONE.
GYSP5: EXCH FXP,FFY2 ;RETURN SYMBOL BLOCK TO FREELIST
EXCH FXP,@FFY2
TLZ FXP,-1 ;MAYBE TRY TO RETURN A VALUE CELL
CAIE FXP,SUNBOUND
JRST GYSP5A
SETZ FXP,
JRST GYSP2
GYSP5A: CAIL FXP,BXVCSG+NXVCSG*SEGSIZ
JRST GYSP5B ;CAN ONLY RETURN CELLS IN VC SPACE
EXCH FXP,FFVC
MOVEM FXP,@FFVC
GYSP5B: SETZ FXP,
JRST GYSP2
;;; MARK AN S-EXPRESSION GIVEN IN A. TRACES IT COMPLETELY,
;;; MARKING ALL SUBITEMS BY SETTING A MARK BIT TO **ZERO**
;;; FOR LIST, FIXNUM, FLONUM, AND BIGNUM SPACES, AND TO
;;; **ONE** FOR SYMBOLS AND SARS. (THIS SPEEDS UP SWEEPING.)
;;; NEVER MARKS VALUE CELLS!!!! (THEY ARE NEVER SWEPT.)
;;; CALLED BY JSP T,GCMARK WITH OBJECT IN A. USES A,B,C,AR1,AR2A.
GCMARK: JUMPE A,(T) ;NEEDN'T MARK NIL
MOVEI AR2A,(P) ;REMEMBER WHERE P IS
GCMRK0: JRST GCMRK1 .SEE KLINIT
GCMRK3: TLNN A,GCBSYM ;MAYBE WE FOUND A SYMBOL
JRST GCMRK4 ;NOPE
HLRZ AR1,(C) ;YUP
TROE AR1,1
JRST GCMKND
HRLM AR1,(C)
PUSH P,(C) ;PUSH PROPERTY LIST
PUSH P,(AR1) ;PUSH PNAME LIST
SKIPN FFVC ;A HAC TO SAVE TIME IF THERE NEVER HAVE BEEN
JRST GCMRK6 ;VALUE CELLS TAKEN FROM LIST SPACE
HRRZ A,@-1(AR1)
JRST GCMRK1 ;GO MARK VALUE OF SYMBOL
GCMRK6: HRRZ A,-1(AR1)
CAIL A,BVCSG
CAIGE A,EVCSG
JRST GCMRK7
HRRZ A,(A)
CAIE A,QUNBOUND
JRST GCMRK1
JRST GCMRK8
GCMRK7: LSH A,-SEGLOG
SKIPL A,GCST(A)
JRST GCMKND
HRRZ A,-1(AR1) ;POINTNG TO A VC IN LIST SPACE
JRST GCMRK1
GCMRK4: TLNN A,GCBVC ;MAYBE WE FOUND A VALUE CELL
JRST GCMRK5 ;NOPE
HRRZ A,(C) ;YUP - MARK ITS CDR (THE VALUE)
JRST GCMRK1
GCMRK5: MOVSI AR1,TTS<GC> ;MUST BE AN ARRAY
IORM AR1,TTSAR(C) ;SET ARRAY MARK BIT TO 1
GCMKND: CAIN AR2A,(P) ;SKIP IF ANYTHING LEFT ON STACK TO MARK
JRST (T) ;ELSE RETURN
GCMRK8: POP P,A ;GET NEXT ITEM TO MARK
GCMRK1: HRRZS C,A ;ZERO LEFT HALF OF A, ALSO SAVE IN C
SETZ B,
LSHC A,-SEGLOG ;GET PAGE NUMBER OF ITEM (OTHER BITS GO INTO B)
SKIPL A,GCST(A) ;CHECK GCST ENTRY FOR THAT PAGE
JRST GCMKND ;NOT MARKABLE - IGNORE IT
TLNE A,GCBFOO ;MAYBE IT'S A VALUE CELL OR SYMBOL OR SAR
JRST GCMRK3 ;IF SO HANDLE IT SPECIALLY
LSHC A,SEGLOG-5 ;THIS GETS ADDRESS OF BIT WORD FOR THIS ITEM
ROT B,5 ;B TELLS US WHICH BIT (40/WD)
MOVE AR1,(A) ;GET WORD OF MARK BITS
TDZN AR1,GCBT(B) ;CLEAR THE ONE PARTICULAR BIT
JRST GCMKND ;QUIT IF ITEM ALREADY MARKED
MOVEM AR1,(A) ;ELSE SAVE BACK WORD OF BITS
JUMPGE A,GCMKND ;JUMP UNLESS WE WANT TO MARK THROUGH (REMEMBER THE LSHC A,5)
HRR A,(C) ;GET CDR OF ITEM
TLNN A,200000 ;MAYBE WE ALSO WANT TO MARK THE CAR
JRST GCMRK1 ;NO - GO MARK CDR
PUSH P,A ;YES - SAVE CDR ON STACK
HLR A,(C) ;GET CAR OF ITEM AND GO MARK IT
IFN HNKLOG, TLNN A,GCBHNK←<SEGLOG-5>
JRST GCMRK1
ZZZ==1
ZZY==GCBHNK&<#GCBH1>
REPEAT <1←HNKLOG>-1,[
PUSH P,.RPCNT+1(C)
HLRZ B,(P)
PUSH P,B
IFE .RPCNT-<<1←ZZZ>-2>,[
TLNN A,ZZY←<SEGLOG-5>
JRST GCMRK1
AAY==ZZY&<#<GCBH1←-ZZZ>>
ZZZ==ZZZ+1
] ;END OF IFE .RPCNT-<<1←ZZZ>-2>
] ;END OF REPEAT <1←HNKLOG>-1
IFN HNKLOG, .VALUE
IFN ITS,[ IFE SEGLOG-11,[ IFLE HNKLOG-5,[
;;; MARK ROUTINE FOR USE WITH KL-10 MICROCODE
LSPGCM=070000,,
LSPGCS=071000,,
KLGCVC: SKIPA A,(A)
PUSH P,B
KLGCM1: LSPGCM A,KLGCM2
KLGCND: CAIN AR2A,(P)
JRST (T)
POP P,A
JRST KLGCM1
KLGCM2: JRST KLGCSY
JRST KLGCVC
JRST KLGCSA
REPEAT HNKLOG, JRST CONC KLGH,\.RPCNT+1
REPEAT 8-.+KLGCM2, .VALUE
KLGCSY: HLRZ AR1,(A)
TROE AR1,1
JRST KLGCND
HRLM AR1,(A)
PUSH P,(A)
PUSH P,(AR1)
HRRZ A,@-1(AR1)
JRST KLGCM1
KLGCSA: MOVSI AR1,TTS<GC>
IORM AR1,TTSAR(A)
JRST KLGCND
IFN HNKLOG,[
ZZZ==<1←HNKLOG>-1
REPEAT HNKLOG,[
CONC KLGH,\HNKLOG-.RPCNT,:
REPEAT 1←<HNKLOG-.RPCNT-1>,[
PUSH P,ZZZ(A)
HLRZ B,(P)
PUSH P,B
ZZZ==ZZZ-1
] ;END OF REPEAT 1←<HNKLOG-.RPCNT-1>
] ;END OF REPEAT HNKLOG
IFN ZZZ, WARN [YOU LOSE]
PUSH P,(A)
HLRZ A,(A)
JRST KLGCM1
] ;END OF IFN HNKLOG
KLGCSW: MOVNI T,3+BIGNUM ;SWEEP
KLGS1: SETZB C,AR1 ;ZERO FREELIST AND COUNT
SKIPN TT,FSSGLK+3+BIGNUM(T)
JRST KLGS1D
KLGS1A: MOVE B,GCST(TT)
LSH B,SEGLOG-5
TLZ B,-1
MOVEI A,(TT)
LSH A,SEGLOG
HRLI A,-SEGSIZ
LSPGCS A,1
LDB TT,[SEGBYT,,GCST(TT)]
JUMPN TT,KLGS1A
KLGS1D: MOVEM C,FFS+3+BIGNUM(T)
HRRM AR1,NFFS+3+BIGNUM(T)
AOJL T,KLGS1
JRST GCSW4A
]]] ;END OF IFLE HNKLOG-5, IFE SEGLOG-11, IFN ITS
GSGEN: SKIPN AR2A,GCMKL ;GENERATE TAILS OF GCMKL AND APPLY
POPJ P, ;FUN IN AR1 TO THEM
PUSH P,AR1
MOVEI AR1,GCMKL
JRST GGEN1
RTSPC2: JUMPE A,GGEN2
RTSP2A: ADD D,TT
GGEN2: HRRZ AR2A,(AR2A) ;GENERAL LOOP FOR GSGEN
MOVEI AR1,(AR2A)
HRRZ AR2A,(AR2A)
GGEN1: JUMPE AR2A,POP1J ;TAIL OF GCMKL IN AR2A,
HRRZ A,(AR2A) ;SPACE OCCUPIED IN TT,
HLRZ A,(A) ;ALIVEP IN A
MOVE TT,(A)
HLRZ A,(AR2A)
HLRZ A,ASAR(A)
JRST @(P) ;ROUTINE WILL RETURN TO GGEN2
GFSPC: PUSH FXP,AR1
PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS
POP FXP,AR1
ADD D,@VBPORG ;NOW HAS TOTAL AMOUNT FREE IN BPS [COUNTING DEAD BLOCKS]
ADD D,GAMNT ;NOW DIMINISHED BY REQUESTED AMOUNT
CAMG D,BPSH
JRST GRELAR ;IF ENOUGH SPACE, THEN RELOCATE
JRST (R)
;GTSP5:
;$$ POP FXP,AR1
GTSP5A: SETZB A,TT ;GIVE OUT NIL AND 0 IF FAIL
JUMPLE AR1,CZECHI
PUSHJ P,BPSGC
JSP R,GFSPC
SETZ AR1,
JRST GTSP1B
BPSGC: MOVEI R,444444 ;GC SPECIFICALLY FOR BPS
HRLM R,(P)
JRST AGC
;;; SOME ROUTINES FOR USE WITH GSGEN
GCP8K: HLRZ A,(D)
JSP T,GCMARK
GCP8J: HRRZ D,(D) ;MARK ATOMS ON OBLIST
GCP8I: JUMPE D,GCP8A ;WHICH HAVE NON-TRIVIAL
MOVE A,D ;P-LIST STRUCTURE.
JSP T,TWAP
JRST GCP8J
JRST GCP8K
JRST GCP8J
GCP8G: JUMPE D,GCP8A ;REMOVE T.W.A.'S FROM
MOVE A,D ;BUCKETS OF OBLIST.
JSP T,TWAP
JRST GCP8B
JRST GCP8B
HRRZ D,(D)
TLNE R,400000 ;BUCKET COMES FROM LH OF WORD IN OBARRAY
HRLM D,(F) ;IF AT THIS POINT R < 0
TLNN R,400000
HRRM D,(F)
JSP T,GCP8L
JRST GCP8G
GCP8C: HRRZ D,(D)
GCP8B: HRRZ A,(D)
GCP8D: JUMPE A,GCP8A
JSP T,TWAP
JRST GCP8C
JRST GCP8C
HRRZ A,(D)
HRRZ A,(A)
HRRM A,(D)
JSP T,GCP8L
JRST GCP8B
GCP8H: MOVE A,D ;MARK OBLIST BUCKET
JSP T,GCMARK
JRST GCP8A
GCP8L: JUMPE TT,(T) ;IF SCO REMOB'D, THEN REMOVE FROM SCO TABLE
HRRZ A,(TT)
JUMPN A,(T)
HLRZ A,(TT)
MOVE B,(A) ;MUST NOT BE INTERRUPTIBLE HERE
MOVEI A,0
LSHC A,7
JUMPN B,(T)
HRRZ TT,VOBARRAY
HRRZ TT,TTSAR(TT)
ADDI TT,<OBTSIZ+1>/2
ROT A,-1
ADD TT,A
JUMPL TT,GCP8L5
HRRZS (TT)
JRST (T)
GCP8L5: HLLZS (TT)
JRST (T)
TWAP: HLRZ A,(A)
JUMPE A,(T) ;NIL IS ALREADY MARKED
HLRZ TT,(A)
TRZE TT,1
JRST (T) ;NO SKIP IF ALREADY MARKED
MOVE B,(TT)
MOVE TT,1(TT)
TLNN B,300 ;SKIP 1 OF SYMBOL HAS SOME NON-TRIVIAL
TLZE TT,-1 ;PROPERTIES, E.G., ARGS OR COMPILED CODE REFERENCE
JRST 1(T)
HRRZ B,(B)
HRRZ A,(A)
CAIN B,QUNBOUND
JUMPE A,2(T) ;SKIP 2 IF TRULY WORTHLESS SYMBOL, I.E., UNBOUND AND NO PROPERITES
JRST 1(T) ;SKIP 1 IF MEANINGFUL PROPERTIES OR VALUE
;;; PRINT MESSAGE OF FORM "NNN[MM%] " FOR GC STATISTICS OUTPUT
STGPNT: PUSH FXP,T ;RECLAIMED AMNT IN T, TOTAL FOR SPACE IN TT
IMULI T,100.
IDIVM T,TT
EXCH TT,(FXP)
Q% MOVEI R,TYO
Q$ HRRZ AR1,VMSGFILES
Q$ TLO AR1,200000
Q$ MOVEI R,$TYO
IFE USELESS, MOVE C,@VBASE ;BASE HAD DAMNED WELL BETTER BE A FIXNUM
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN ;SKIPS
] ;END OF IFN USELESS
PUSHJ P,PRINI2
STRT 17,[SIXBIT \[!\] ;BEWARE THESE BRACKETS!!!!!
POP FXP,TT
IFE USELESS, MOVEI C,10.
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,[10.]
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI3 ;EFFECTIVELY, PRINI2 WITH *NOPOINT=T
STRT 17,[SIXBIT \%] !\] ;BEWARE THESE BRACKETS!!!!!
POPJ P,
;;; VERY IMPORTANT TABLE OF WORDS WITH SINGLE BITS!!! USED FOR MARKING!!!
GCBT: REPEAT 36., SETZ←-.RPCNT
IFE D10,[
SUBTTL RETURN CORE TO TIMESHARING SYSTEM
;;; HAIRY ROUTINE TO DECIDE WHETHER TO RETURN SOME BPS TO THE SYSTEM.
;;; MAY ONLY BE CALLED WHEN NOQUIT SPECIFIES NO INTERRUPTS.
RETSP: MOVEI TT,4 ;GTSPC1 IS ALLOWED TO GRAB 4 PAGES
MOVEM TT,ARPGCT ; BEFORE INVOKING GC FOR LACK OF CORE
PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS
MOVE TT,BPSH
LSH TT,-PAGLOG ;CURRENT HIGHEST CORE BLOCK IN BPS
MOVE R,@VBPORG
ADDI R,1(D)
LSH R,-PAGLOG ;CORE NEEDED IF ARRAYS WERE PACKED
CAML R,TT
POPJ P,
LSH R,PAGLOG
ADDI R,PAGSIZ-1
HRLM R,RTSP1 ;NEW BPSH
SUB R,D
HRRM R,RTSP3 ;NEW BPEND.
JUMPE D,RTSP5
HRLM D,RTSP3 ;NO. OF CELLS TO MOVE.
PUSHJ P,GRELAR ;(LEAVES BPEND-AFTER-RELOCATION IN TT.)
HRL AR1,TT
HRR AR1,RTSP3 ;BLOCK PTR.
SUBI TT,(AR1)
JUMPLE TT,RTSP2
MOVNI TT,1(TT)
HRRM TT,RTSP1
ADD AR1,R70+1
HLRZ C,RTSP3
ADD C,RTSP3
BLT AR1,(C)
MOVEI AR1,RTSPC1
PUSHJ P,GSGEN ;DO PATCH-UP ON ARRAY PARAMETERS
JSP T,RSXST ;????
RTSP2: HLRZ TT,RTSP1
MOVE R,TT
EXCH R,BPSH
HRRZ D,RTSP3
MOVEM D,@VBPEND
IFE D10,[
LSH R,-PAGLOG ;OLD CORE HIGHEST
LSH TT,-PAGLOG ;NEW CORE HIGHEST
SUBI R,(TT)
MOVEI F,1(TT)
ROT F,-4
ADDI F,(F)
ROT F,-1
TLC F,770000
ADD F,[450200,,PURTBL]
MOVEI D,1(TT)
LSH D,-SEGLOG+PAGLOG
MOVE T,[$NXM,,QRANDOM]
SETZ AR1,
LSH TT,11
RTSP7: ADDI TT,1000
.CBLK TT,
POPJ P,
TLNN F,730000
TLZ F,770000
IDPB AR1,F
REPEAT SGS%PG, MOVEM T,ST+.RPCNT(D)
ADDI D,SGS%PG
SOJG R,RTSP7
] ;END OF IFE D10
10$ CORE TT,
10$ LERR [SIXBIT \CORE?!\]
POPJ P,
RTSP5: SETZM GCMKL ;NO ARRAYS ALIVE
MOVE TT,R
PUSHJ P,BPNDST ;SETQ UP BPEND
JRST RTSP2
RTSPC1: JUMPE A,GGEN2
HRRE B,RTSP1 ;-(SIZE OF SHIFT + 1).
JSP AR1,GT3D
JRST GGEN2
] ;END OF IFE D10
SUBTTL GET SPACE FROM TIMESHARING SYSTEM
GTSPC1: HLLOS NOQUIT
JSP R,GFSPC ;SEE IF FREE SPACE ABOVE BPEND WILL ADD ENOUGH
SKIPLE AR1,ARPGCT
JRST GTSP1B
PUSHJ P,BPSGC ;WHEN COMPACTIFIED AND RELOCATED
JSP R,GFSPC ;IF NOT, GC AND TRY AGAIN
GTSP1B:
IFE D10,[
CAML D,HINXM
JRST GTSP5A
MOVEI T,(D)
TRO T,PAGSIZ-1
MOVE R,BPSH
LSH D,-PAGLOG
LSH R,-PAGLOG
SUB D,R
MOVN F,D
ADDM F,ARPGCT
MOVEI F,1(R)
ROT F,-4
ADDI F,(F)
ROT F,-1
TLC F,770000
ADD F,[450200,,PURTBL]
MOVEI TT,1(R)
LSH TT,-SEGLOG+PAGLOG
MOVE A,[$XM,,QRANDOM]
PUSH FXP,AR1
HLRZ AR1,(P) ;BEWARE! LH OF CALLING PDL SLOT = -1
TRNN AR1,1 ; MEANS THE GETSP FUNCTION IS CALLING
TROA AR1,3
MOVEI AR1,1
LSH R,11
IOR R,[004400,,400000]
GTSPC2: ADDI R,1000
.CBLK R,
; JRST GTSP5 ;FAILURE GIVES OUT NIL IN A, 0 IN TT
.LOSE 1000+%ENACR ;NO CORE AVAILABLE - TELL DDT
TLNN F,730000
TLZ F,770000
IDPB AR1,F
REPEAT SGS%PG, MOVEM A,ST+.RPCNT(TT)
ADDI TT,SGS%PG
SOJG D,GTSPC2
POP FXP,AR1
MOVEM T,BPSH ;FALLS INTO GRELAR
] ;END OF IFE D10
IFN D10,[
SETZB A,TT ;GIVE OUT NIL AND 0 IF WE FAIL
JRST CZECHI
] ;END OF IFN D10
GRELAR: HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE.
HRRZ A,BPSH ;LEAVE BPEND-AFTER-RELOCATION AS RESULT
MOVEM A,GSBPN ;TEMPORARY BPEND
MOVEI AR1,GTSPC3
PUSHJ P,GSGEN ;RELOCATE ARRAYS
JSP T,RSXST
GREL1: MOVE TT,GSBPN
PUSHJ P,BPNDST
MOVE TT,(A)
CZECHI: HLLZS NOQUIT
JRST CHECKI ;CHECK FOR ↑G THEN POPJ P,
SUBTTL ARRAY RELOCATOR
CNLAC: MOVEI D,0 ;COUNT NUMBER OF LIVING ARRAY CELLS, IN D
MOVEI AR1,RTSPC2
JRST GSGEN
BPNDST: JSP T,FIX1A ;STORE NEW VALUE FOR BPEND
MOVEM A,VBPEND
POPJ P,
;;; COMES HERE FROM GRELAR VIA GSGEN. AR2A HAS TAIL OF GCMKL, TT HAS TOTAL LENGTH OF ARRAY
GTSPC3: JUMPE A,GT3G ;RELOCATE AN ARRAY
MOVEI AR1,-1(TT) ;LENGTH-1 OF ARRAY IN AR1
HLRZ A,(AR2A)
HRRZ A,ASAR(A)
SUBI A,1 ;ARRAY AOBJN PTR LOC IN A.
MOVE C,GSBPN
SUBI C,(AR1)
MOVEM C,GSBPN ;LOC NEW BPTR IN C
MOVEI B,(C)
SUBI B,1(A) ;RELOCATION AMOUNT-1 IN B
CAML A,C ;IS ARRAY ALREADY IN PLACE?
JRST GT3C ;YES, SO EXIT
SUBI C,(AR1)
CAMGE A,C ;BEWARE: C COULD GO NEGATIVE!
JRST GT3A ;GOOD, EASY BLT
ADDI C,(AR1)
ADDI AR1,1(A) ;FIRST DESTINATION LOC
GT3B: HRRZI C,(AR1)
SUBI AR1,1(B) ;CONSTRUCT SOURCE ADDRESS
HRLI C,(AR1)
HRRZI T,(C)
ADDI T,(B)
BLT C,(T) ;SERIES OF SMALL BLTS
CAMLE AR1,GSBPN
JRST GT3B
ADDI AR1,(B)
SUB AR1,GSBPN
MOVE A,GSBPN
SUBI A,1(B)
GT3A: MOVE C,GSBPN
ADDI AR1,(C)
HRL C,A
BLT C,(AR1) ;FINAL (OR ONLY) BLT
JSP AR1,GT3D
GT3C: SOS GSBPN
JRST GGEN2
GT3D: ADDI B,1
HLRZ A,(AR2A)
ADDM B,ASAR(A) ;UPDATE ARRAY POINTERS BY OFFSET IN B
ADDM B,TTSAR(A)
MOVE C,ASAR(A)
ADDM B,-1(C) ;UPDATE AOBJN PTR BEFORE ARRAY HEADER
Q% JRST (AR1)
IFN QIO,[
HRR C,TTSAR(A)
TLNE C,AS<FIL>
SKIPGE F.MODE(C)
JRST (AR1)
MOVE C,TTSAR(A)
10% ADDM B,AB.BP(C) .SEE XB.AOB
10% ADDM B,FB.IOT(C)
10$ ADDM B,FB.NBF(C)
JRST (AR1)
] ;END OF IFN QIO
GT3G: HRRZ AR2A,(AR2A)
HRRZ AR2A,(AR2A)
HRRM AR2A,(AR1) ;CUT OUT DEAD BLOCK
JRST GGEN1
PGTOP GC,[GARBAGE COLLECTOR]
;;; ********** MEMORY MANAGEMENT, ETC **********
SUBTTL PURCOPY FUNCTION
PGBOT BIB
PURCOPY: PUSHJ FXP,SAV5M2
PUSH P,[RST5M2]
PUSH FXP,CCPOPJ
PUSHJ P,SAVX5
PUSH P,[RSTX5]
MOVEI TT,(A) ;USES A,B,T,TT
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,PUR+VC
POPJ P,
2DIF JRST (TT),PCOPY9,QLIST .SEE STDISP
PCOPY9: JRST PCOPLS ;LIST
JRST PCOPFX ;FIXNUM
JRST PCOPFL ;FLONUM
BG$ JRST PCOPBN ;BIGNUM
JRST PCOPSY ;SYMBOL
REPEAT HNKLOG, LERR PCOPER ;HUNKS
POPJ P, ;RANDOM
MOVSI TT,100 ;ARRAY
IORM TT,(A) ;SET "COMPILED CODE NEEDS ME" BIT
POPJ P,
IFN HNKLOG, PCOPER: SIXBIT \CAN'T PURCOPY A HUNK YET!\
PCOPLS: HLRZ B,(A) ;PURCOPY A LIST ALREADY
PUSH P,B
HRRZ A,(A)
PUSHJ P,PURCOPY
EXCH A,(P)
PUSHJ P,PURCOPY
POP P,B
PCONS: AOSL TT,NPFFS ;PURE FS CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG ;NOTE: CLOBBERS TT
ADD TT,EPFFS
NOPRO
HRLM A,(TT)
HRRM B,(TT)
MOVEI A,(TT)
POPJ P,
PCOPFX: MOVE TT,(A)
PFXCONS: CAIGE TT,XHINUM ;PURE FIXNUM CONSER
CAMGE TT,[-XLONUM]
JRST PFXC1
MOVEI A,IN0(TT)
POPJ P, ;NOTE: EXITS WITH POPJ P,!!!
PFXC1: AOSL A,NPFFX
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD A,EPFFX
NOPRO
PFXC3: MOVEM TT,(A)
POPJ P,
PCOPFL: MOVE TT,(A)
PFLCONS: AOSL A,NPFFL ;PURE FLONUM CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD A,EPFFL
NOPRO
JRST PFXC3 ;ALSO EXITS WIRH POPJ P,!!!
IFN BIGNUM,[
PCOPBN: PUSH P,(A)
HRRZ A,(A)
PUSHJ P,PURCOPY
HLL A,(P)
SUB P,R70+1
PBNCONS: AOSL TT,NPFFB ;PURE BIGNUM CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD TT,EPFFB
NOPRO
MOVEM A,(TT)
MOVEI A,(TT)
POPJ P,
] ;END OF IFN BIGNUM
PCOPSY: PUSH P,A
HLRZ B,(A)
MOVE TT,(B)
TLNE TT,200
JRST PCOPS1
PUSH P,B
HRRZ A,1(B)
PUSHJ P,PURCOPY
POP P,B
HRRM A,1(B)
MOVSI TT,100
IORM TT,(B)
PCOPS1: LOCKI
JSP TT,ATMHSH
IDIVI T,OBTSIZ
PUSH FXP,TT
MOVEI A,(FXP)
MOVE T,VOBARRAY
PUSHJ P,@ASAR(T)
MOVEI B,(A)
HRRZ A,(P)
PUSHJ P,MEMQ
POP FXP,D
JUMPN A,PCOPS3
MOVEI T,1 ;GCPROTECT
HRRZ A,(P)
PUSHJ P,.GCPRO
PCOPS3: UNLOCKI
JRST POPAJ
IFE D10,[
SUBTTL GETCOR
;;; THIS ROUTINE IS SPECIFICALLY FOR PEOPLE WHO HAND-CODE LAP.
;;; IT IS USED TO ALLOCATE A NUMBER OF CONSECUTIVE PAGES
;;; OF MEMORY FOR VARIOUS PURPOSES, E.G. HACKING OF PDP-11'S
;;; OR INFERIOR JOBS OR WHATEVER.
;;; THE NUMBER OF PAGES DESIRED SHOULD BE IN TT; THE LOW ADDRESS
;;; OF THE PAGES IS RETURNED IN TT, OR ZERO FOR FAILURE.
;;; THIS ROUTINE DOES NOT ACTUALLY GET CORE; IT MERELY RESERVES
;;; ADDRESS SPACE.
;;; THERE IS CURRENTLY NO PROVISION FOR RETURNING THE MEMORY GRABBED.
GETCOR: HLLOS NOQUIT
LSH TT,PAGLOG
MOVE T,HINXM
SUBI T,(TT)
CAMGE T,BPSH
JRST GTCOR6
MOVEI F,(TT) ;GETTING F THIS WAY FLUSHES
LSH F,-PAGLOG ; RANDOM BITS. (IT'S SAFER.)
GTCOR4: JSP R,ALIMPG
.VALUE ;HOW CAN WE LOSE HERE?
SOJG F,GTCOR4
SKIPA TT,HINXM
GTCOR6: TDZA TT,TT ;LOSE, LOSE, LOSE
ADDI TT,1
JRST CZECHI
SUBTTL PDL OVERFLOW HANDLER
;PDLSTH: 0 ;HACK ST FOR ADDING PDL PAGES
PDLST0: MOVEI R,(D) ;USED BY PDLHAK TO EXTEND PDLS
LSH R,11-PAGLOG ;D HAS BASE ADDRESS OF PAGE DESIRED
IOR R,[4400,,400000] ;USES ONLY D AND R
.CBLK R, ;CAUSE NEW PDL PAGE TO EXIST
.LOSE 1000+%ENACR ;NO CORE AVAILABLE
MOVEI R,(D) ;CALCULATE PURTBL BYTE POINTER
ROT R,-PAGLOG-4
ADDI R,(R)
ROT R,-1
TLC R,770000
ADD R,[430200,,PURTBL]
MOVEM P,FAKFXP ;SAVE P AT BOTTOM OF FAKE FXPDL
MOVEI P,3
DPB P,R ;UPDATE PURTBL
LSH D,-SEGLOG ;HORRIBLE HACKERY TO UPDATE ST
ADD D,[-SGS%PG-1,,ST-1] ; WITHOUT AN EXTRA AC:
Q% REPEAT SGS%PG, PUSH D,PDLST9-P(A) ; USE PUSHES! (CAN'T OVERFLOW)
Q$ REPEAT SGS%PG, PUSH D,PDLST9-P(F) ; USE PUSHES! (CAN'T OVERFLOW)
MOVE P,FAKFXP
JRST @PDLSTH
;;; IFE D10
IFE QIO,[
;PDLHAK: 0 ;CALLED WHEN SOME PDL OVERFLOWS
PDLH0: MOVEM D,QITD ;A=0 => CAUSED BY PUSH OR PUSHJ, ELSE
MOVEM R,QITR ; UINT0 GIVES <# SLOTS NEEDED,,PDL AC>
JUMPN A,PDLH0A ;SO JUMP IF WE KNOW WHICH ONE
MOVEI A,P ;ALL RIGHT THEN, LET'S PLAY
JUMPGE P,PDLH0A ; TWENTY QUESTIONS - IS IT REGPDL?
MOVEI A,SP
JUMPGE SP,PDLH0A ;SPECPDL?
MOVEI A,FXP
JUMPGE FXP,PDLH0A ;FXP?
MOVEI A,FLP ;IF NOT FLP, THEN USER HAS LOST!
JUMPL FLP,[LERR [SIXBIT \USER PDL OVERFLOW!\]]
; JUMPGE FLP,PDLH0A
;IRP Z,,[P,FLP,FXP,SP]
; MOVES (Z) ;CROCK DUE TO ITS LOSSAGE
;TERMIN
; JRST PDLH3
PDLH0A: HRRZ R,(A) ;FETCH RIGHT HALF OF PDL POINTER
MOVEI D,(R)
CAML R,OC2-P(A) ;IF WE'RE OVER THE ORIGIN OF THE
JRST PDLH5 ; OVERFLOW PDL, THEN ERROR OUT
HLRZ R,A
ADDI R,11(D) ;HERE IS A HACK TO PAGIFY
IORI R,PAGSIZ-1 ; UPWARDS, BUT KEEP WELL AWAY
SUBI R,10 ; FROM THE PAGE BOUNDARY
CAML R,OC2-P(A) ;IF WE'RE ABOVE THE OVERFLOW PDL,
MOVE R,OC2-P(A) ; ONLY INCREASE TO THAT PLACE
CAMGE D,ZPDL-P(A) ;SKIP IF WE'RE ABOVE PDLMAX
JRST PDLH2 ; PARAMETER FOR THIS PDL
TLO A,-1 ;SET FLAG TO INDICATE THIS FACT
MOVE D,MORPDL-P(A) ;PUSH UP THE PDLMAX
ADD D,ZPDL-P(A) ; "SOME MORE"
ANDI D,777760 ;BUT KEEP AWAY FROM PAGE
TRNN D,PAGKSM ; BOUNDARY (PICKY, PICKY!)
SUBI D,20
MOVEM D,ZPDL-P(A)
HRRZ D,(A)
JRST PDLH2A
PDLH2: TLZE A,-1
JRST PDLH2B
CAMLE R,ZPDL-P(A) ;IF OUR GUESS WOULD PUT US OVER
PDLH2A: MOVE R,ZPDL-P(A) ; PDLMAX, GO ONLY AS FAR AS THAT
PDLH2B: SUBI D,(R) ;CALCULATE NEW LEFT HALF FOR PDL PTR
HRLM D,(A) ;CLOBBER INTO PDL PTR
HRRZ D,(A) ;FIGURE OUT IF WE NEED TOP GET
ADDI R,10 ; MORE CORE FOR ALL THIS
ANDI R,PAGMSK
EXCH R,D
CAIG R,(D) ;SKIP IF WE CROSSED NO PAGE BOUNDARY
JSR PDLSTH ;ELSE MUST GET NEW PAGE AND UPDATE ST
TLZN A,-1 ;SKIP IF WE WERE ABOVE PDLMAX
JRST PDLH3
HRLI A,QREGPDL-P(A)
HRRI A,12. ;STACK UP USER INT 12. (PDL-OVERFLOW)
HRRZ D,PDLHAK ;CAN STACK IT BECAUSE WE'RE IN UINT,
CAIN D,PDLOV3+1 ; WHICH WILL DO A CHECKI
JRST PDLH4
MOVE D,QITD ;RESTORE D AND R SO UISTAK
MOVE R,QITR ; CAN SAVE THEM AGAIN
JSR UISTAK
PDLH3: SETZ A,
PDLH4: MOVE D,QITD ;A NON-ZERO MEANS WE WANT TO RUN
MOVE R,QITR ; A PDL-OVERFLOW INT
JRST @PDLHAK
] ;END OF IFE QIO
;;; IFE D10
IFN QIO,[
;;; HAIRY PDL OVERFLOW HANDLER
PDLOV: MOVE F,INTPDL
MOVEM D,IPSWD2(F) ;SAVE D
MOVEM R,IPSWD1(F) ;SAVE R
SKIPL INTPDL
.VALUE ;I WANT TO SEE THIS! - GLS
MOVEI F,P ;ALL RIGHT THEN, LET'S PLAY
JUMPGE P,PDLH0A ; TWENTY QUESTIONS - IS IT REGPDL?
MOVEI F,SP
JUMPGE SP,PDLH0A ;SPECPDL?
MOVEI F,FXP
JUMPGE FXP,PDLH0A ;FXP?
MOVEI F,FLP ;IF NOT FLP, THEN IT'S PRETTY RANDOM
JUMPGE FLP,PDLH0A
HLRZ R,NOQUIT
JUMPN R,PDLH3A
LERR [SIXBIT \RANDOM PDL OVERFLOW!\]
PDLH0A: HRRZ R,(F) ;FETCH RIGHT HALF OF PDL POINTER
MOVEI D,(R)
CAML R,OC2-P(F) ;IF WE'RE OVER THE ORIGIN OF THE
JRST PDLH5 ; OVERFLOW PDL, THEN ERROR OUT
HLRZ R,F
ADDI R,11(D) ;HERE IS A HACK TO PAGIFY
IORI R,PAGSIZ-1 ; UPWARDS, BUT KEEP WELL AWAY
SUBI R,10 ; FROM THE PAGE BOUNDARY
CAML R,OC2-P(F) ;IF WE'RE ABOVE THE OVERFLOW PDL,
MOVE R,OC2-P(F) ; ONLY INCREASE TO THAT PLACE
CAMGE D,ZPDL-P(F) ;SKIP IF WE'RE ABOVE PDLMAX
JRST PDLH2 ; PARAMETER FOR THIS PDL
TLO F,-1 ;SET FLAG TO INDICATE THIS FACT
MOVE D,MORPDL-P(F) ;PUSH UP THE PDLMAX
ADD D,ZPDL-P(F) ; "SOME MORE"
ANDI D,777760 ;BUT KEEP AWAY FROM PAGE
TRNN D,PAGKSM ; BOUNDARY (PICKY, PICKY!)
SUBI D,20
MOVEM D,ZPDL-P(F)
HRRZ D,(F)
JRST PDLH2A
PDLH2: TLZE F,-1
JRST PDLH2B
CAMLE R,ZPDL-P(F) ;IF OUR GUESS WOULD PUT US OVER
PDLH2A: MOVE R,ZPDL-P(F) ; PDLMAX, GO ONLY AS FAR AS THAT
PDLH2B: SUBI D,(R) ;CALCULATE NEW LEFT HALF FOR PDL PTR
HRLM D,(F) ;CLOBBER INTO PDL PTR
HRRZ D,(F) ;FIGURE OUT IF WE NEED TOP GET
ADDI R,10 ; MORE CORE FOR ALL THIS
ANDI R,PAGMSK
EXCH R,D
CAIG R,(D) ;SKIP IF WE CROSSED NO PAGE BOUNDARY
JSR PDLSTH ;ELSE MUST GET NEW PAGE AND UPDATE ST
TLZN F,-1 ;SKIP IF WE WERE ABOVE PDLMAX
JRST PDLH3A
MOVSI D,QREGPDL-P(F)
HRRI D,1005 ;PDL-OVERFLOW
HRRZ R,INTPDL
HRRZ R,IPSPC(R)
CAIL R,UINT0 ;AVOID DEEP INTERRUPT RECURSION:
CAILE R,EUINT0 ; IF PDL OVERFLOWED WITHIN UINT0,
JRST PDLH4 ; THEN JUST STACK UP THE INTERRUPT,
JSR UISTAK ; AND SOMEONE WILL EVENTUALLY TRY CHECKI
PDLH3A: HRRZ F,INTPDL
JRST INTXT1
PDLH4: MOVE R,FXP ;ELSE TRY TO GIVE A PDL OVERFLOW
SKIPE GCFXP ; USER INTERRUPT IMMEDIATELY
MOVE FXP,GCFXP ;REMEMBER, PDL OVERFLOW IS NOT
PUSH FXP,R ; DISABLED INSIDE THE PDL
PUSHJ FXP,IWAIT ; OVERFLOW HANDLER!!!
PUSHJ P,UINT
HRRZ F,INTPDL ;RESTORE THE WORLD
JRST INTXIT
] ;END OF IFN QIO
;;; IFE D10
IFE QIO,[
PDLOV: .SUSET [.SIPIRQC,,A]
SETZ A, ;MEANS WE DON'T KNOW WHICH PDL YET
PDLOV3: JSR PDLHAK ;FIGURE IT OUT
JUMPE A,INTEX1
MOVEM A,CNTROL ;THIS IS A HACK
MOVEI A,INTEX1
EXCH A,CNTROL
JRST UINT1R ;GO RUN PDL-OVERFLOW INTERRUPT
] ;END OF IFE QIO
MORPDL: 400 ;AMOUNTS TO INCREMENT PDLS BY
100 ; WHEN OVERFLOW OCCURS (THIS GIVES
LSWS+100 ; LOSER A CHANCE TO SSTATUS PDLMAX,
200 ; AT LEAST)
PDLMSG: POVPDL ;REG
POVFLP ;FLONUM
POVFXP ;FIXNUM
POVSPDL ;SPEC
PDLST9: $XM,,QRANDOM ;TYPICAL ST ENTRIES FOR PDL PAGES
$FLP,,QFLONUM
$FXP,,QFIXNUM
$XM,,QRANDOM
PDLH5: IORI R,PAGSIZ-1 ;BAD PDL OV - REALLY DESPERATE
SUBI D,-2(R) ;GIVE US AS MUCH PDL AS IS LEFT
JUMPL D,PDLH6
MOVE P,C2
MOVE FXP,FXC2
SETZM TTYOFF
STRT UNRECOV
Q% STRT @PDLMSG-P(A)
Q$ STRT @PDLMSG-P(F)
JRST DIE
PDLH6:
Q% HRLM D,(A)
Q$ HRLM D,(F)
HLRZ R,NOQUIT
JUMPN R,GCPDLOV ;FOO! HAPPENED IN GC - BOMB OUT!
Q% HRRZ B,PDLMSG-P(A)
Q$ HRRZ B,PDLMSG-P(F)
CAIE B,POVSPDL
JRST PDLOV5 ;PDLOV5 HANDLE WILL GET US TO TOP LEVEL
MOVEM P,F ;FOR SP, TRY TO POP BINDINGS FIRST
HRRZ TT,SPSV ; SO *RSET-TRAP WON'T OVERFLOW
MOVE P,[-LFAKP-1,,FAKP] ;SO WE HAVE ENOUGH PDL FOR UBD
PUSH P,FXP
MOVE FXP,[-LFAKFXP-1,,FAKFXP]
PUSHJ P,UBD
POP P,FXP
MOVE P,F
JRST PDLOV5 ;PDLOV5 WILL SET UP PDLS
] ;END OF IFE D10
SUBTTL PURE SEGMENT CONSER
;;; GTNPSG IS INVOKED AS FOLLOWS:
;;; AOSL A,NPFF% ;SKIP UNLESS NO MORE LEFT
;;; SPECPRO INTPPC
;;; PUSHJ P,GTNPSG ;MUST GET MORE
;;; ADD A,EPFF% ;ELSE JUST FIGURE OUT ABSOLUTE ADDRESS
;;; NOPRO
;;; WHERE % IS SOME APPROPRIATE LETTER (E.G. S, X, L, B).
;;; GTNPSG UPDATES NPFF% AND EPFF% BY LOOKING AT THE AOSL, THEN
;;; RETURNS TO THE AOSL.
XCTPRO
GTNPSG: HLLOS NOQUIT ;GET NEW PURE SEGMENT
NOPRO
SOS (P)
SOS (P)
SAVEFX T TT D
GTNPS1: MOVEI T,-SEGSIZ ;*NOT* "MOVNI T,SEGSIZ" !!!
ADDB T,PSGAOB ;INCR'S LH BY 1, DECR'S RH BY SEGSIZ
JUMPGE T,GTNPS3 ;FOO! MUST GRAB A NEW PAGE!
TLZ T,-1
LSH T,-SEGLOG
MOVE D,@(P) ;D POINTS TO NPFF%
MOVE TT,GTNPS8-NPFFS(D)
MOVEM TT,ST(T)
SETZM GCST(T)
LSH T,SEGLOG
ADDI T,SEGSIZ
MOVEM T,EPFFS-NPFFS(D) ;UPDATE PARAMETERS FOR NEW
MOVNI T,SEGSIZ+1 ; PURE SEGMENT
MOVEM T,(D)
MOVEI T,SEGSIZ
ADDM T,PFSSIZ-NPFFS(D) ;UPDATE STORAGE SIZE
RSTRFX D TT T
JRST CZECHI
GTNPS8: LS+$FS+PUR,,QLIST ;TYPICAL ST ENTRIES FOR PURE SEGMENTS
$FX+PUR,,QFIXNUM
$FL+PUR,,QFLONUM
BG$ BN+PUR,,QBIGNUM
$XM+PUR,,QRANDOM
GTNPS3:
IFE D10,[
MOVE T,HINXM ;FIGURE OUT IF ANY ROOM LEFT
SUBI T,PAGSIZ
CAMGE T,BPSH
] ;END OF IFE D10
IFN D10,[
MOVE TT,HIXM
ADDI TT,PAGSIZ
CAMLE TT,MAXNXM
] ;END OF IFN D10
LERR [SIXBIT \NO SPACE FOR NEW PURE PAGE!\]
IFE D10,[
AOS TT,HINXM
MOVEM T,HINXM ;UPDATE HINXM
HRLI TT,-SGS%PG-1
MOVEM TT,PSGAOB ;UPDATE AOBJN PTR
MOVEI TT,1(T)
] ;END OF IFE D10
IFN D10,[
MOVEM TT,HIXM
HRLI TT,-SGS%PG-1
MOVEM TT,PSGAOB
AOS PSGAOB
TLZ TT,-1
] ;END OF IFN D10
LSH TT,-SEGLOG ;UPDATE ST AND GCST FOR NEW PAGE
MOVE D,[$XM+PUR,,QRANDOM]
REPEAT SGS%PG, MOVEM D,ST+.RPCNT(TT)
REPEAT SGS%PG, SETZM GCST+.RPCNT(TT)
IFE D10,[
MOVEI TT,1(T) ;UPDATE PURTBL
ROT TT,-PAGLOG-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[430200,,PURTBL]
DPB T,TT ;T HAS 11 IN LOW TWO BITS
MOVEI TT,1(T) ;MEANS CAN PURIFY IF WE THINK ABOUT IT
LSH TT,11-PAGLOG
IOR TT,[4400,,400000]
.CBLK TT,
.LOSE 1000+%ENACR
] ;END OF IFE D10
IFN D10,[
HRRZ TT,HIXM
CORE TT,
.VALUE
] ;END OF IFN D10
JRST GTNPS1
SUBTTL FREE STORAGE SPACE EXPANSION
;;; THIS PORTION OF THE GARBAGE COLLECTOR DETERMINES WHETHER
;;; WE SHOULD JUST GRAB A NEW SEGMENT OF FREE STORAGE FOR SOME
;;; CONSER, OR DO A FULL-BLOWN GARBAGE COLLECTION. IT IS
;;; CONTROLLED BY PARAMETERS SETTABLE VIA (SSTATUS GCSIZE ...).
GCGRAB: MOVN R,D
JFFO R,.+1 ;DETERMINE WHICH SPACE WANTED MORE
SUBI F,NFF
MOVEI AR2A,1 ;MACRAK SEZ: GRAB JUST ONE
SKIPN FFY2
SETZ F,
JUMPE F,GCGRB1 ; ... SEZ MACRAK
MOVE D,SFSSIZ+NFF(F)
CAML D,GFSSIZ+NFF(F) ;CAN'T JUST GRAB IF ABOVE SIZE
JRST AGC1Q ; SPECIFIED FOR "FREE GRABBIES"
MOVE D,GFSSIZ+NFF(F)
CAMLE D,XFFS+NFF(F) ;CAN'T GRAB IF IT WOULD PUT
JRST AGC1Q ; US ABOVE THE MAXIMUM SIZE
GCGRB1: PUSH FXP,AR2A
PUSHJ P,GRABWORRY
POP FXP,AR1
JUMPL AR2A,GCEND ;JUMP IF WE GOT ALL THE CORE
JRST AGC1Q ;GO DO FULL-BLOWN GC AFTER ALL
;;; THIS ROUTINE WORRIES ABOUT GETTING A NEW IMPURE FREE STORAGE
;;; SEGMENT. (FOR PURE FREE STORAGE SEGMENTS, SEE GTNPSG.)
;;; MUST DO SPECIAL HACKERY FOR SYMBOL AND SAR SPACES, SINCE THEY
;;; REQUIRE MORE THAN ONE CONSECUTIVE SEGMENT. PRINTS OUT PRETTY
;;; MESSAGES IF GCGAG IS NON-NIL.
;;; MUST HAVE NOQUIT NON-ZERO AND ST/GCST PAGES IMPURE WHEN ENTERING!
GCWORRY: SUBI AR2A,(TT) ;ENTRY FOR GARBAGE COLLECTOR
ADDI AR2A,SEGSIZ-1 ;FIGURE OUT HOW MANY NEW SEGMENTS WE NEED
LSH AR2A,-SEGLOG
GRABWORRY:
Q$ HRRZ AR1,VMSGFILES
Q$ TLO AR1,200000
JUMPE F,.+2 ;ENTRY FOR GCGRAB
SKIPN GCGAGV ;MAYBE WE WANT A PRETTY MESSAGE?
SOJA AR2A,GCWOR2 ;IF NOT, DECR AR2A (SEE BELOW)
STRT 17,[SIXBIT \↑M;ADDING !\]
SOJG AR2A,GCWR0A ;AR2A GETS DECR'ED HERE, TOO!
STRT 17,[SIXBIT \A!\] ;KEEP THE ENGLISH GOOD
JRST GCWR0B
GCWR0A:
Q% MOVEI R,TYO
Q$ MOVEI R,$TYO
MOVEI TT,1(AR2A)
Q$ PUSH FXP,AR2A
IFE USELESS, MOVE C,@VBASE ;BASE DAMN WELL BETTER BE A FIXNUM
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
Q$ POP FXP,AR2A
GCWR0B: STRT 17,[SIXBIT \ NEW !\]
STRT 17,@GSTRT9+NFF(F)
STRT 17,[SIXBIT \ SEGMENT!\]
SKIPE AR2A
STRT 17,[SIXBIT \S!\]
GCWOR2: SKIPE TT,IMSGLK
JRST GCWR2A ;JUMP IF ANY SEGMENTS AVAILABLE
JSP R,ALIMPG ;ELSE MUST GRAB A NEW PAGE
JRST GCWOR7
GCWR2A: LDB D,[SEGBYT,,GCST(TT)]
MOVEM D,IMSGLK ;CDR THE FREE SEGMENT LIST
MOVE D,FSSGLK+NFF(F) ;CONS NEW SEGMENT ONTO LIST
MOVEM TT,FSSGLK+NFF(F) ; OF SEGMENTS FOR THE
HRRZ R,BTBAOB ; PARTICULAR SPACE
HLL R,GCWORS+NFF(F)
LSH D,22-<SEGLOG-5>
TLNE R,$FS+$FX+$FL+BN+HNK
IORI D,(R) ;MAYBE ALLOCATE A BIT BLOCK FOR
IOR D,GCWORG+NFF(F) ; THE NEW SEGMENT FOR USE BY
MOVEM D,GCST(TT) ; GC IN MARKING CELLS
MOVE D,GCWORS+NFF(F) ;UPDATE ST ENTRY FOR THE
MOVEM D,ST(TT) ; NEW SEGMENT
MOVE D,FFS+NFF(F) ;ADD CELLS OF SEGMENT TO
LSH TT,SEGLOG ; THE FREE STORAGE
MOVEM D,(TT) ; LIST FOR THIS SPACE
MOVE D,[GCWORX,,1]
BLT D,LPROG9
HLL TT,GCWORN+NFF(F)
HRR GCWRX1,GCWORN+NFF(F)
HRRI GCWRX2,-1(GCWRX1)
JRST GCWRX1
GCWR2C: HRRZM TT,FFS+NFF(F)
TLNN R,$FS+$FX+$FL+BN+HNK
JRST GCWR4Q
HRRZ TT,BTBAOB ;DECIDE WHETHER THIS BIT BLOCK
LSH TT,SEGLOG-5 ; LIES IN MAIN BIT BLOCK AREA
MOVEI D,-1(TT)
CAME D,MAINBITBLT
JRST GCWR3A
ADDI D,BTBSIZ ;YES - JUST UPDATE MAIN BLT
MOVEM D,MAINBITBLT ; POINTER FOR CLEARING
JRST GCWR3B ; BIT BLOCKS (SEE GCINBT)
GCWR3A: LSH TT,-SEGLOG ;ELSE AOS COUNT OF BIT BLOCKS
AOS GCST(TT) ; IN CURRENT BIT BLOCK SEGMENT
GCWR3B: MOVE TT,BTBAOB ;AOBJN THE BIT BLOCK
AOBJN TT,GCWOR4 ; ALLOCATION POINTER
SKIPE TT,IMSGLK ;FOO! OUT OF BIT BLOCKS!
JRST GCWR3F
JSP R,ALIMPG ;FOO FOO! NEED NEW PAGE!
JRST GCWFOO
GCWR3F: LDB D,[SEGBYT,,GCST(TT)]
MOVEM D,IMSGLK ;CDR LIST OF FREE SEGMENTS
MOVE D,[$XM,,QRANDOM] ;UPDATE ST AND GCST FOR
MOVEM D,ST(TT) ; NEW BIT BLOCK SEGMENT
MOVEI D,(TT) ;GCST ENTRY IS USED TO
LSH D,5 ; INDICATE HOW MANY
MOVEM D,GCST(TT) ; BLOCKS ARE IN USE
MOVE D,BTSGLK ;CONS NEW SEGMENT ONTO LIST
DPB D,[SEGBYT,,GCST(TT)] ; OF BIT BLOCK SEGMENTS
MOVEM TT,BTSGLK
LSH TT,5 ;CALCULATE NEW BIT BLOCK
HRLI TT,-SEGSIZ/BTBSIZ ; ALLOCATION POINTER
GCWOR4: MOVEM TT,BTBAOB
GCWR4Q: JUMPE F,GCWOR6
MOVEI TT,SEGSIZ ;UPDATE VARIOUS GC PARAMETERS
ADDM TT,NFFS+NFF(F)
ADDB TT,SFSSIZ+NFF(F)
CAMLE TT,XFFS+NFF(F) ;MUST STOP IF OVER MAX
SOJA AR2A,.+2 ;KEEP COUNT ACCURATE
GCWOR6: SOJGE AR2A,GCWOR2 ;ALSO STOP IF WE GOT ALL WE WANT
GCWOR7: JUMPE F,CPOPJ
SKIPN GCGAGV ;MAYBE WANT MORE PRETTY MESSAGE
POPJ P,
SKIPL AR2A
STRT 17,[SIXBIT \↑M; BUT CAN'T GET THEM ALL!\]
STRT 17,[SIXBIT \ - - !\]
STRT 17,@GSTRT9+NFF(F)
STRT 17,[SIXBIT \ SPACE NOW !\]
Q% MOVEI R,TYO
IFN QIO,[
MOVEI R,$TYO
PUSH FXP,AR2A
HRRZ AR1,VMSGFILES
TLO AR1,200000
] ;END OF IFN QIO
MOVE TT,SFSSIZ+NFF(F)
IFE USELESS, MOVE C,@VBASE
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
STRT 17,[SIXBIT \ WORDS↑M!\]
Q$ POP FXP,AR2A
POPJ P,
GCWORG: GCBMRK+GCBCDR+GCBCAR,, ;TYPICAL GCST ENTRIES FOR IMPURE SPACES
GCBMRK,,
GCBMRK,,
BG$ GCBMRK+GCBCDR,,
GCBMRK+GCBSYM,,
REPEAT HNKLOG, GCBMRK+GCBCDR+GCBCAR+<GCBH1←-.RPCNT>,,
GCBMRK+GCBSAR,,
IFN .-GCWORG-NFF, WARN [WRONG LENGTH TABLE]
0
GCWORS: LS+$FS,,QLIST ;TYPICAL ST ENTRIES
$FX,,QFIXNUM
$FL,,QFLONUM
BG$ BN,,QBIGNUM
SY,,QSYMBOL
REPEAT HNKLOG, LS+HNK,,QHUNK1+.RPCNT
SA+$XM,,QARRAY
IFN .-GCWORS-NFF, WARN [WRONG LENGTH TABLE]
$XM,,QRANDOM
GCWFOO: STRT [SIXBIT \↑M;GLEEP#! OUT OF BIT BLOCKS!\]
JRST GCWOR7
GCWORX: ;EXTEND FREELIST THROUGH NEW SEGMENT
OFFSET 1-.
GCWRX1: HRRZM TT,1(TT) ;OCCUPIES A,B,C,AR1 - MUST SAVE AR2A
GCWRX2: ADDI TT,.
AOBJN TT,GCWRX1
JRST GCWR2C
LPROG9==.-1
OFFSET 0
.HKILL GCWRX1 GCWRX2
GCWORN: -SEGSIZ+1,,1 ;LIST
-SEGSIZ+1,,1 ;FIXNUM
-SEGSIZ+1,,1 ;FLONUM
BG$ -SEGSIZ+1,,1 ;BIGNUM
-SEGSIZ+1,,1 ;SYMBOL
REPEAT HNKLOG, -SEGSIZ/<2←.RPCNT>+1,,2←.RPCNT ;HUNKS
-SEGSIZ/2+1,,2 ;ARRAY SARS
IFN .-GCWORN-NFF, WARN [WRONG LENGTH TABLE]
-SEGSIZ/2+1,,2 ;SYMBOL BLOCKS
SUBTTL IMPURE PAGE GOBBLER
;;; ALLOCATE AN IMPURE PAGE FREE STORAGE USE
ALIMPG:
IFE D10,[
MOVE TT,HINXM ;MUST SAVE AR2A AND F FOR GCWORRY
SUBI TT,PAGSIZ
CAMGE TT,BPSH
] ;END OF IFE D10
IFN D10,[
MOVE TT,HIXM
ADDI TT,PAGSIZ
CAMLE TT,MAXNXM
] ;END OF IFN D10
JRST (R) ;NO PAGES LEFT - RETURN WITHOUT SKIP
IFE D10,[
MOVEM TT,HINXM ;ELSE UPDATE HINXM
MOVEI TT,1(TT)
LSH TT,11-PAGLOG
IOR TT,[4400,,400000]
.CBLK TT, ;SO GET THE NEW PAGE OF CORE
.LOSE 1000+%ENACR ;NO CORE AVAILABLE
MOVE TT,HINXM
MOVEI D,1(TT) ;COMPUTE A MAGIC BYTE POINTER
LSH D,-PAGLOG
ROT D,-4
ADDI D,(D)
ROT D,-1
TLC D,770000
ADD D,[430200,,PURTBL]
MOVEI C,1
DPB C,D ;UPDATE THE PURTBL
TLZ R,-1
CAIN R,GTCOR4+1 ;DON'T HACK IMSGLK FOR GETCOR
JRST 1(R)
] ;END OF IFE D10
IFN D10,[
MOVEM TT,HIXM
CORE TT,
.VALUE
MOVE TT,HIXM
] ;END OF IFN D10
LSH TT,-SEGLOG
10% ADDI TT,SGS%PG
MOVE C,IMSGLK ;UPDATE ST AND GCST, AND ADD
MOVE AR1,[$XM,,QRANDOM] ; NEW SEGMENTS TO IMSGLK LIST
MOVEI D,SGS%PG
ALIMP3: MOVEM AR1,ST(TT)
SETZM GCST(TT)
DPB C,[SEGBYT,,GCST(TT)]
MOVEI C,(TT)
SOJE D,ALIMP4
SOJA TT,ALIMP3
ALIMP4: MOVEM TT,IMSGLK ;WINNING RETURN SKIPS
JRST 1(R) ;EXITS WITH LOWEST NEW SEGMENT # IN TT
SUBTTL RECLAIM FUNCTION
IFN BIGNUM+USELESS,[
RECL1: SKOTT A,LS+PUR
2DIF JRST (TT),RECL9-1,QLIST .SEE STDISP
TLNE TT,HNK+VC+PUR ;DON'T RECLAIM VALUE CELLS!!! (OR HUNKS)
POPJ P, ; - ALSO DON'T RECLAIM PURE WORDS
PUSH P,A ;SAVE ARG
JUMPE B,RECL2 ;B=NIL => RECLAIM ONLY TOP LEVEL OF LIST
HLRZ A,(A) ;RECLAIM CAR
PUSHJ P,RECL1
RECL2: MOVE T,FFS
POP P,FFS
EXCH T,@FFS ;RECLAIM ONE CELL
MOVEI A,(T) ;AND THEN GO AFTER THE CDR
JRST RECL1
REFXS: JUMPE B,RECL9A ;B=NIL => DON'T RECLAIM FULLWORDS
TLNE TT,$FXP ;DON'T RECLAIM PDL LOCATIONS!!!
POPJ P,
MOVE T,FFX ;RECLAIM FIXNUM
MOVEM T,(A)
MOVEM A,FFX
POPJ P,
REFLS: JUMPE B,RECL9A ;B=NIL => DON'T RECLAIM FULLWORDS
TLNE TT,$FLP ;DON'T RECLAIM PDL LOCATIONS!!!
POPJ P,
MOVE T,FFL ;RECLAIM FLONUM
MOVEM T,(A)
MOVEM A,FFL
POPJ P,
IFN BIGNUM,[
REBIG: MOVE T,FFB ;RECLAIM BIGNUM HEADER
EXCH T,(A)
MOVEM A,FFB
MOVEI A,(T) ;RECLAIM CDR OF BIGNUM
JRST RECL1
] ;END OF IFN BIGNUM
RECL9: JRST REFXS ;FIXNUM
JRST REFLS ;FLONUM
BG$ JRST REBIG ;BIGNUM
RECL9A: POPJ P, ;SYMBOL
REPEAT HNKLOG, .VALUE ;HUNKS
POPJ P, ;RANDOM
POPJ P, ;ARRAY
IFN .-RECL9-NTYPES+1, WARN [WRONG LENGTH TABLE]
] ;END OF IFN BIGNUM+USELESS
IFN ITS,[
SUBTTL VALUE CELL AND SYMBOL BLOCK HACKERY
;;; ROUTINE TO GET MORE VALUE CELL SPACE.
;;; EXPANDS VALUE CELL SPACE BY GETTING NEXT PAGE IN THE HOLE
;;; LEFT FOR THIS PURPOSE, AND EXTENDING THE VALUE CELL FREELIST.
;;; IF NO PAGES LEFT IN THE HOLE, A LIST CELL IS USED.
XCTPRO
MAKVC3: HLLOS NOQUIT
NOPRO
SOSL NFVCP
JRST MAKVC4
PUSHJ P,CZECHI
PUSHJ P,CONS1
JRST MAKVC1
MAKVC4: MOVE A,EFVCS
LSH A,11-PAGLOG
IOR A,[4400,,400000]
.CBLK A, ;SO GET THE NEW PAGE IN OUR CORE MAP
.LOSE 1000+%ENACR ;NO CORE AVAILABLE
MOVE A,EFVCS
MOVEM A,FFVC
LSH A,-SEGLOG
MOVE TT,[LS+VC,,QLIST]
REPEAT SGS%PG, MOVEM TT,ST+.RPCNT(A)
MOVSI TT,GCBMRK+GCBVC
REPEAT SGS%PG, MOVEM TT,GCST+.RPCNT(A)
LSH A,-PAGLOG+SEGLOG ;UPDATE PURTBL
ROT A,-4
ADDI A,(A)
ROT A,-1
TLC A,770000
ADD A,[430200,,PURTBL]
MOVEI TT,1
DPB TT,A
AOS TT,EFVCS
HRLI TT,-PAGSIZ+1
HRRZM TT,-1(TT)
AOBJN TT,.-1
HRRZM TT,EFVCS
MAKVC8: PUSHJ P,CZECHI
JRST MAKVC0
] ;END OF IFN ITS
;;; SYMBOL BLOCK COPYING ROUTINE - TRIGGERED BY PURE PAGE TRAP, OR EXPLICIT CHECK
;;; B POINTS TO OLD SYMBOL BLOCK
;;; LEAVES POINTER TO NEW SYMBOL BLOCK IN B
;;; CLOBBERS TT, LEAVES POINTER TO VALUE CELL IN A
LDPRG9: TLCA B,LDPARG ;FASLOAD CLOBBERING ARGS PROP
ARGCL7: TLC B,ARGCL3 ;ARGS CLOBBERING ARGS PROP
HRRZ A,(B)
JRST MAKVC6
MAKVC9: TLCA B,MAKVCX ;MAKVC CLOBBERING IN VALUE CELL
MAKVC5: PUSHJ P,AGC
BAKPRO
MAKVC6: SKIPN FFY2 ;COME HERE IF HRRM ABOVE CAUSES
JRST MAKVC5 ; A PURE PAGE TRAP - MUST COPY
MOVE TT,@FFY2 ; SYMBOL BLOCK FOR THAT SYMBOL
XCTPRO
EXCH TT,FFY2
NOPRO
HRLI A,777100 ;ASSUME COMPILED CODE NEEDS IT
MOVEM A,(TT) ; (THINK ABOUT THIS SOME MORE)
MOVE A,1(B)
MOVEM A,1(TT)
HRRZ A,(TT)
HRLM TT,@(P)
EXCH TT,B
HLRZ TT,TT
JRST (TT)
SUBTTL ALLOC FUNCTION
$ALLOC: CAIE A,TRUTH ;SUBR 1 - DYNAMIC ALLOC
JRST $ALLC5
SETO F, ;ARG=T => MAKE UP LIST
EXCH F,INHIBIT ;CROCKISH LOCKI - DOESN'T MUNG FXP
MOVNI R,NFF
$ALLC6: PUSH FXP,GFSSIZ+NFF(R) ;SAVE UP VALUABLE DATA
PUSH FXP,XFFS+NFF(R) ;LOCKI KEEPS IT CONSISTENT
PUSH FXP,MFFS+NFF(R)
AOJL R,$ALLC6
10% REPEAT 4, PUSH FXP,XPDL+.RPCNT
MOVEM F,INHIBIT ;EQUALLY CROCKISH UNLOCKI
PUSHJ P,CHECKI
PUSH P,R70
IFN ITS,[
MOVEI R,4
$ALLC9: POP FXP,TT
SUB TT,C2-1(R)
TLZ TT,-1
JSP T,FIX1A
MOVE B,(P)
PUSHJ P,CONS
MOVEI B,QREGPDL-1(R)
PUSHJ P,XCONS
MOVEM A,(P)
SOJG R,$ALLC9
] ;END OF IFN ITS
MOVEI R,NFF
$ALLC7: SKIPN SFSSIZ-1(R)
JRST $ALLC8 ;SPACE SIZE IS ZERO - IGNORE IT
POP FXP,TT
PUSHJ P,SSGP2A
PUSHJ P,NCONS
MOVEI B,(A)
POP FXP,TT
JSP T,FIX1A
PUSHJ P,CONS
MOVEI B,(A)
POP FXP,TT
JSP T,FIX1A
PUSHJ P,CONS
MOVE B,(P)
PUSHJ P,CONS
MOVEI B,QLIST-1(R)
CAIN B,QRANDOM
MOVEI B,QARRAY
PUSHJ P,XCONS
MOVEM A,(P)
JRST $ALLC4
$ALLC8: SUB FXP,R70+3 ;FLUSH GARBAGE
$ALLC4: SOJG R,$ALLC7
JRST POPAJ
$ALLC0: HRRZ A,(AR2A)
$ALLC5: JUMPE A,TRUE ;DECODE LIST OF PAIRS
HLRZ B,(A) ;ARG IS LIST OF SAME FORM AS
HRRZ AR2A,(A) ; A .LISP. (INIT) COMMENT
HLRZ C,(AR2A)
CAIL B,QREGPDL
CAILE B,QSPECPDL
JRST $ALLC3
MOVEI D,1←-1 ;SSPDLMAX
PUSHJ P,SSGP3$
JRST $ALLC0
$ALLC3: JSP R,SFRET
JRST $ALLC0
JRST $ALLC0
SETZ AR1,
MOVEI F,(C)
SKOTT C,LS
JRST $ALLC2
HRRZ AR1,(C)
HLRZ C,(C)
HLRZ F,(AR1)
SKIPE AR1
SKIPA AR1,(AR1)
SKIPA F,C
HLRZ AR1,(AR1)
$ALLC2: MOVEI D,3←-1 ;SSGCSIZE
PUSHJ P,SSGP3$
MOVEI C,(F)
MOVEI D,5←-1 ;SSGCMAX
PUSHJ P,SSGP3$
MOVEI C,(AR1)
MOVEI D,7←-1 ;SSGCMIN
PUSHJ P,SSGP3$
JRST $ALLC0
PGTOP BIB,[MEMORY MANAGEMENT STUFF]
;;@ END OF GCBIB 122
;;@ READER 92 READ AND RELATED FUNCTIONS
PGBOT [RDR]
SUBTTL HIRSUTE READER AND INPUT PACKAGE
IFN NEWRD,[
;;;DEFINE READER-SYNTAX BITS
;;;THESE BITS OCCUPY 2.1-3.8. DO NOT USE 3.9 (SEE TYIPEEK)
RS.FF==004000,, ;FORCE-FEED CHARACTER
RS.VMO==002000,, ;VERTICAL MOTION (LF, FF)
RS.SQX==001000,, ;EXPONENT MARKER, STRING QUOTE
RS.BRK==000400,, ;SPECIAL ACTION NEEDED ON INPUT
RS.SCO==000200,, ;SINGLE-CHARACTER OBJECT
RS.WSP==000100,, ;WHITE SPACE - SPACE, TAB, COMMA
RS.LP ==000040,, ;LEFT PARENTHESIS
RS.DOT==000020,, ;DOTTED-PAIR DOT
RS.RP ==000010,, ;RIGHT PARENTHESIS
RS.MAC==000004,, ;MACRO-CHARACTER (RS.ALT = SPLICING)
RS.SLS==000002,, ;SLASHIFIER
RS.RBO==000001,, ;RUBOUT, FORCEFEED
RS.SL1==400000 ;SLASH IF FIRST IN PNAME
RS.PNT==200000 ;DECIMAL POINT (FOR NUMBERS)
RS.SL9==100000 ;SLASH IF NOT FIRST IN PNAME
RS.ALT==040000 ;CHANGE MEANING OF OTHER BITS
RS.ARR==020000 ;NUMBER MODIFIERS ← AND ↑
RS.SGN==010000 ;NUMBERS SIGNS + AND -
RS.DIG==004000 ;DIGITS 0 THROUGH 9
RS.XLT==002000 ;EXTENDED LETTERS (LIKE :)
RS.LTR==001000 ;REGULAR LETTERS (LIKE X)
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==<RS.!A>←22
TERMIN
NWTNE==:TRNE
NWTNN==:TRNN
DEFINE NWTN ZP,AC,SX
TDN!ZP AC,[RS.!SX]
TERMIN
] ;END IFN NEWRD
IFE NEWRD,[
;;;DEFINE READER-STYNTAX BITS
RS.FF==0
RS.VMO==0
RS.SQX==0
RS.BRK==400000
RS.SCO==200000
RS.WSP==100000
RS.LP==40000
RS.DOT==20000
RS.RP==10000
RS.MAC==4000
RS.SLS==2000
RS.RBO==1000
RS.SL1==400
RS.PNT==200
RS.SL9==100
RS.ALT==40
RS.ARR==20
RS.SGN==10
RS.DIG==4
RS.XLT==2
RS.LTR==1
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==RS.!A
TERMIN
NWTNE==:TLNE
NWTNN==:TLNN
DEFINE NWTN ZP,AC,SX
TLN!ZP AC,RS.!SX
TERMIN
] ;END OF IFE NEWRD
RS.CMS==RS.<BRK+SL1+SL9+MAC> ;CHARACTER-MACRO SYNTAX
RS.SCS==RS.<BRK+SL1+SL9+SCO> ;SINGLE-CHAR-OBJ SYNTAX
RS.OBB==RS.<SQX+SCO+LP+MAC+SLS+PNT+SGN+DIG+XLT+LTR> ;SYNTAX FOR CHARS THAT BEGIN OBJECTS
RS.WTH==RS.<OBB+DOT+RP+ARR> ;PRETTY MUCH, ANY WORTHY CHAR
RS.SEE==RS.<WTH+WSP+RBO+FF> ;ALMOST ANY CHAR THAT YOU REALLY SEE
SUBTTL READCH AND ASCII FUNCTIONS, OLD I/O TYI FUNCTION
$READCH:
Q% JSP R,ORD
Q$ JSP D,INCALL
Q$READCH
READCH: PUSHJ P,TYI
RDCH3: MOVE TT,A
JRST RDCH2
$ASCII: JSP T,FXNV1
RDCH2: ANDI TT,177
MOVE B,TT
MOVE D,VOBARRAY
ADDI TT,OBTSIZ+1
ROT TT,-1
JUMPL TT,.+3
HLRZ A,@1(D)
JRST .+2
HRRZ A,@1(D)
JUMPN A,CPOPJ
JRST RDCHO
IFE QIO,[
%TYI:
$TYI: SKIPA R,[400000,,MAKNUM]
CA2TT: MOVEI R,A2TT
JUMPN T,$TYI1
PUSH P,R
CTYI: JRST TYI
A2TT: MOVEI TT,(A) ;WHEN TYI PRODUCES AN ANSWER IN A
CAILE TT,300. ;AND WE WANT THE ANSWER IN TT, WE JUST
MOVE TT,(TT) ;MOVE IT THERE, AND CHECK FOR THE CASE OF
POPJ P, ;E-O-F CAUSING INPUT ARG TO BE IN A
$TYI1A: %WTA FXNMER
JRST $TYI1B
$TYI1: MOVEI D,Q%TYI
CAME T,XC-1
JRST WNALOSE
POP P,A
$TYI1B: SKOTT A,FX
JRST $TYI1A
JUMPGE R,.+2
PUSH P,CFIX1
PUSH P,CA2TT
PUSH P,A
JSP R,ORD
Q%TYI
TYI: SKIPE A,TYIMAN
JRST (A)
SKIPN TAPRED ;NOTE HOW THIS MUST SAVE D - SEE $TYI
JRST TYI1
PUSHJ P,URED
SKIPA A,CTYI ;CONTAINS "TYI"
POPJ P,
.UEOF: PUSH P,A
10% .CLOSE UTIC,
10$ CLOSE UTIC,
10$ RELEASE UTIC,
MOVE A,[0700,,UTIB-1]
MOVEM A,UTIBP
MOVSI A,<↑C>←13
HLLM A,UTIB
SETZB A,UTIOPD
SETOM AFILRD
SETZM TAPRED
SKIPN EOFRTN
C15: POPJ P,15
RDTRB3: MOVE P,EOFRTN
JRST ERR1
;;; IFE QIO
TYI1: SKIPN B,RDTYBF
JRST TYIN
PUSHJ P,RDIN2
TYI2: CAIGE A,200
POPJ P,
CAIN A,203
JRST TYI1
CAILE A,TLRCT-1
LER3 [SIXBIT \RANDOM CHAR - TYI!\]
HRRZ A,RCT0(A) ;CAUSE PROPER TRANSLATION OF THE "SUPRA-ASCII" PSEUDO CHARS
POPJ P,
TYIN: MOVEI A,0
EXCH A,PBFTY
JUMPN A,TYI2
SETZM TAPRED
TTYTYI:
IFN ITS,[
SPECPRO INTTYI
.IOT TYIC,A
NOPRO
CAIN A,↑U ;FLUSH ↑U FROM TTY INPUT SINCE IT IS
JRST TTYTYI ;FOR RELEASING THE PAGEPAUSE
POPJ P,
] ;END OF IFN ITS
IFN D10,[
SKIPN LINMODE
JRST TTYTY1
SPECPRO INTTYI
INCHWL A
NOPRO
JRST TTYTY2
SPECPRO INTTYI
TTYTY1: INCHRW A
NOPRO
TTYTY2:
IFN SAIL,[
TRNE A,400 ;META?
POPJ P, ;YES
TRNN A,200 ;CONTROL?
POPJ P, ;NO
CAIGE A,300 ;IS IT A LETTER TYPE CONTROL CHAR?
POPJ P, ;NO
PUSH P,A
TRZ A,300
JSR CNTROL
JRST POPAJ
] ;END IFN SAIL
.ELSE,[
CAILE A,↑↑
POPJ P,
PUSH P,A
JSR CNTROL
JRST POPAJ
] ;END IFE SAIL
] ;END OF IFN D10
;; This is the pre-processor for converting from the SAIL ASCII
;; character set to DEC style.
IFN SAIL,[
SAILPP: CAIN A,32 ;A TILDE?
JRST SAIPP1
CAIN A,176 ;A }
JRST SAIPP2
CAIE A,175 ;AN ALTMODE
JRST SAIPP3
MOVEI A,33
JRST SAIPP3
SAIPP1: MOVEI A,176
JRST SAIPP3
SAIPP2: MOVEI A,175
SAIPP3: TRZE A,600 ;CTRL/META/BOTH?
TRZ A,100 ;MAKE DEC STYLE
POPJ P,
] ;END OF IFN SAIL
;;; IFE QIO
URED: SKIPN UTIOPD
JRST UREDER
10$ SOSGE UTIBYT
10$ JRST UREDBF
ILDB A,UTIBP
10$ JUMPE A,URED
CAIE A,↑C
JRST POPJ1
MOVEI A,UTIB+UTBSIZ
CAIE A,@UTIBP
POPJ P,
UREDBF:
IFN ITS,[
MOVE A,[-UTBSIZ,,UTIB]
.IOT UTIC,A
CAMN A,[-UTBSIZ,,UTIB]
POPJ P,
HRLI A,<↑C>←13 ;IN CASE WE READ IN A MULTIPLE OF 5
HLLZM A,(A) ; CHARS: WE MIGHT NOT HAVE GOTTEN A ↑C
MOVE A,[440700,,UTIB]
MOVEM A,UTIBP
JRST URED
] ;END OF IFN ITS
IFN D10,[
IN UTIC,
JRST URED
STATZ UTIC,20000 ;CHECK FOR EOF
POPJ P,
JRST URED
] ;END OF IFN D10
ORD: JUMPE T,1(R) ;SET-UP RETURN FOR READ WITH ARG
AOSE T ;MUST SAVE TT - SEE $TYI
JRST ORD7
SKIPE EOFRTN
JRST ORD3
PUSH P,[ORD1]
JSP T,ERSTP
MOVEM P,EOFRTN
PUSHJ P,1(R)
SUB P,[LERSTP+2,,LERSTP+2] ;REMOVE [ARG], [ORD1], AND ERSTP
ORD2: SETZM EOFRTN
POPJ P,
ORD1: POP P,A
JRST ORD2
ORD3: SUB P,R70+1
JRST 1(R)
ORD7: MOVE D,(R)
SOJA T,WNALOSE
] ;END OF IFE QIO
IFN QIO,[
SUBTTL NEWIO INPUT FUNCTION ARGS PROCESSOR
;;; JSP D,INCALL
;;; Q<FNNAME>
;;; PROCESSES ARGUMENTS FOR AN INPUT FUNCTION TAKING STANDARD
;;; ARGUMENTS (EOF VALUE AND/OR FILE ARRAY). SAVES F.
;;; JSP D,XINCALL
;;; Q<FNNAME>
;;; IS SIMILAR, BUT INSISTS ON A FIXNUM RESULT (FOR TYI, TYIPEEK),
;;; AND EXPECTS F TO CONTAIN EITHER "FIX1" OR "CPOPJ".
;;; SAVES AR2A (SEE TYIPEEK).
XINCALL: JUMPN T,XINCA1
PUSH P,F
JRST 1(D)
XINCA1: TLOA D,1 ;MUST HAVE FIXNUM RESULT
INCALL: JUMPE T,1(D) ;ZERO ARGS - TRIVIAL
AOJL T,INCAL2
POP P,AR1 ;ONE ARG - IS IT A FILE?
JUMPE AR1,EOFBN0 ;NOT IF NIL
JSP TT,XFILEP
JRST EOFBN0 ;NOT IF T, OR IF NOT FILE
INCAL1: SETZ A, ;DEFAULT EOF VALUE IS NIL
INBIND: SKIPE B,AR1
JRST INBN4
PUSHJ P,INFGET ;GETS VINFILE IN AR1
MOVEI B,(AR1)
INBN4: CAIN B,TRUTH
TDZA C,C
SKIPA C,[TRUTH]
HRRZ AR1,V%TYI
; PUSHJ P,ATIFOK
; UNLOCKI
MOVSI T,-LINBN9 ;OPEN-CODING OF SPECBIND
MOVEM SP,SPSV
INBN1: HRRZ TT,INBN9(T)
HRRZ R,(TT)
HRLI R,(TT)
PUSH SP,R
HLRZ R,INBN9(T)
TRNN R,777760
HRRZ R,(R)
MOVEM R,(TT)
AOBJN T,INBN1
JSP T,SPECX ;END OF SPECBIND
PUSH P,CUNBIND
JRST EOFBIND
INBN9: C,,TAPRED ;TABLE OF VALUE CELLS FOR INBIND
B,,VINFILE ; EACH ENTRY IS OF FORM:
NIL,,VINSTACK ; <NEW VALUE>,,<VALUE CELL>
$DEVICE,,TYIMAN ; IF NEW VALUE IS AN AC, THEN
UNTYI,,UNTYIMAN ; THE AC CONTAINS THE REAL
;; UNRD,,UNREADMAN ; NEW VALUE.
;; READP,,READPMAN
LINBN9==.-INBN9
INCAL2: AOJL T,INCAL7
POP P,A ;TWO ARGS
POP P,AR1
JUMPE AR1,INBIND
CAIN AR1,TRUTH
JRST INBIND
JSP TT,XFILEP
EXCH A,AR1
JRST INBIND
INCAL7: HRRZ D,(D) ;MORE THAN TWO ARGS: FOOEY.
JRST S2WNAL
EOFBN0: MOVEI A,(AR1)
EOFBIND: TLNN D,1 ;BIND FOR INPUT EOF TRAP
JRST EOFBN3
PUSH P,F ;FOR NUMERICAL INPUT FN, FIX1 OR CPOPJ
TLO A,400000
EOFBN3: PUSH P,A
PUSH P,CEOFBN5
JSP T,ERSTP ;SET UP A FRAME
MOVEM P,EOFRTN ;THIS IS AN EOF FRAME
SETZM BFPRDP .SEE EOF2
PUSHJ P,1(D) ;RUN CALLING FUNCTION
MOVSI D,-LEP1+1(P) ;RESTORE FRAME STUFF
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,[LERSTP+2,,LERSTP+2] ;FLUSH FRAME
POPJ P, ;RETURN (RESULT IN A OR TT)
EOFBN5: POP P,A ;COME HERE ON EOF
TLZN A,400000
CEOFBN5: POPJ P,EOFBN5
SKIPN A ;FOR A NULL EOF VALUE, SNEAKILY
SKIPA TT,XC-1 ; SLIP IN A -1 INSTEAD
JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED
POPJ P, ; MUST BE A FIXNUM
;;; IFN QIO
SUBTTL NEWIO END-OF-FILE HANDLING
;;; HANDLE EOF ON STANDARD FILE ARRAY IN AR1.
EOF: PUSHJ FXP,SAV5
HRRZ T,BFPRDP ;CHECK WHETHER IN READ
JUMPN T,EOFE
EOF2: MOVEI TT,FI.EOF
HRRZ B,@TTSAR(AR1)
JUMPE B,EOF5
EXCH B,AR1
SKIPE A,EOFRTN
HRRZ A,-LERSTP-1(A) .SEE EOFBIND
EXCH A,B
CALLF 2,(AR1)
JUMPN A,EOF4
EOF8: PUSHJ P,INPOP
PUSHJ P,EOF7
EOF1: JSP R,PDLA2-5
POPJ P,
EOF7: HRRZ A,-2(P) ;SAVED AR1
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY> ;DON'T CLOSE TTY INPUT,
PUSHJ P,ICLOSE ; FOR THAT WAS MERELY OVER-RUBOUT
POPJ P,
EOF4: CAIN A,TRUTH
JRST EOF1
SKIPN T,EOFRTN
JRST EOF8
HRRM A,-LERSTP-1(T) .SEE EOFBIND
EOF9: MOVE P,EOFRTN .SEE TYPK9
JRST ERR1
EOF5: PUSHJ P,EOF7
PUSHJ P,INPOP ;NO EOF FUNCTION
SKIPN EOFRTN
JRST EOF1
JRST EOF9
;;; IFN QIO
SUBTTL NEWIO INPUSH FUNCTION
;;; HAIRY INPUSH FUNCTION. PUSHES FILE ONTO INSTACK,
;;; OR MAYBE PUSHES INFILE, OR MAYBE POPS.
;;; INPOP POPS INSTACK INTO INFILE ONCE.
INPU0: WTA [BAD ARG - INPUSH!]
INPUSH: CAIN A,TRUTH ;SUBR 1
HRRZ A,V%TYI
JSP TT,AFILEP
JRST INPU2
PUSHJ P,ATIFOK
UNLOCKI
EXCH A,VINFILE
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM B,VINSTACK
INPU1: SKIPN A,VINFILE
JRST INPU12
CAIN A,TRUTH
SETZM TAPRED
POPJ P,
INPU12: PUSHJ P,INFLUZ
JRST INPU1
INPU2: SKOTT A,FX
JRST INPU0
SKIPN TT,(A)
JRST INPU1
JUMPL TT,INPU5
INPU3: HRRZ A,VINFILE ;AN INPUSH LOOP
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM A,VINSTACK
SOJG TT,INPU3
JRST INPU1
INPOP: MOVNI TT,1
PUSH P,A ;MUST SAVE A (E.G., SEE LOAD)
PUSH P,CPOPAJ
INPU5: PUSH FXP,TT
INPU6: SKIPN A,VINSTACK
JRST INPU8
HLRZ AR1,(A)
; PUSHJ P,ATIFOK
; UNLOCKI
HLRZ AR1,(A)
MOVEM AR1,VINFILE
HRRZ A,(A)
MOVEM A,VINSTACK
AOSGE (FXP)
JRST INPU6
INPU7: SUB FXP,R70+1
JRST INPU1
INPU8: MOVEI A,TRUTH
MOVEM A,VINFILE
JRST INPU7
;;; IFN QIO
SUBTTL NEWIO TYI FUNCTION AND RELATED ROUTINES
%TYI: SKIPA F,CFIX1 ;LSUBR (0 . 2) NCALLABLE
MOVEI F,CPOPJ
JSP D,XINCALL
Q%TYI
MOVEI A,Q%TYI
HRLZM A,BFPRDP
PUSHJ P,@TYIMAN
SETZM BFPRDP
POPJ P,
TYI: PUSHJ P,@TYIMAN
MOVEI A,(TT) ;CRAP
POPJ P,
;;; MAIN UNTYI ROUTINE
;;; ACCEPTS CHARACTER IN A AND INPUT FILE IN VINFILE.
;;; STICKS CHARACTER BACK INTO CHARACTER BUFFER.
;;; CLOBBERS A,B,AR1,T,TT,D. MUST SAVE C (SEE READ).
UNTYI: PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
MOVEI D,200000(A) ;USE 200000 BIT (IN CASE OF ↑@)
MOVEI TT,FI.BBC
HLRZ T,@TTSAR(AR1) ;GET SINGLE BUFFERED CHAR
JUMPE T,UNTYI3 ;THERE IS NONE - THIS IS EASY
HRRZ B,@TTSAR(AR1) ;FOOEY - WE MUST CONS THE
MOVEI TT,-200000(T) ; OLD BUFFERED BACK CHAR
JSP T,FXCONS ; INTO THE LIST TO LEAVE ROOM
PUSHJ P,CONS ; FOR THE NEW ONE
MOVEI TT,FI.BBC
HRRZM A,@TTSAR(AR1)
UNTYI3: HRLM D,@TTSAR(AR1) ;BUFFER BACK NEW CHAR
POPJ P,
;;; MAIN INPUT FILE ARRAY HANDLER
;;; FILE ARRAY IN VINFILE.
;;; SAVES A,B,C,AR2A; CLOBBERS AR1.
;;; RETURNS CHARACTER IN TT.
;;; ACCUMULATOR D IS ZERO FOR PEEKING, ELSE 1.
$PEEK: TDZA D,D
$DEVICE: MOVEI D,1
$DEV0: PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
MOVSI T,TTS.CL
TDNE T,TTSAR(AR1)
JRST $DVLUZ ;INPUT (FILE) CLOSED LOSSAGE!
.5LOCKI
MOVE T,TTSAR(AR1)
SKIPE FI.BBF(T)
JRST $DEVER
SKIPN TT,FI.BBC(T)
JRST $DEV2
TLZN TT,200000
JRST $DEV1
HLRZ TT,TT
SKIPE D
HRRZS FI.BBC(T)
JRST $DEV7
$DEV1: MOVS TT,(TT)
SKIPE D
HLRZM TT,FI.BBC(T)
MOVE TT,(TT)
JRST $DEV7
$DVLUZ: PUSHJ P,INFLZZ
JRST $DEV0
$DEV2: HLRZ R,BFPRDP
TLNN T,TTS<TY> ;IF THIS ISN'T A TTY,
JRST $DEV4 ; THEN FORGET CLEVER HACKS
CAIN R,Q%TYI ;IF THIS IS TYI, THEN
JRST $DEV4H ; PULL CLEVER ACTIVATION HACK
JUMPE R,$DEV4 ;NIL MEANS NO CLEVERNESS AT ALL
HRRZ R,TI.BFN(T) ;FORGET PRE-SCAN IF THERE IS
JUMPE R,$DEV4Q ; NO PRE-SCAN FUNCTION
$DEV2B: HRLM D,(P)
PUSHJ FXP,SAV5 ;OTHERWISE SAVE THE WORLD
MOVEI A,(AR1) ;INVOKE THE PRE-SCAN FUNCTION
HLRZ B,BFPRDP ; WITH THREE ARGUMENTS:
MOVEI AR2A,(R) ; (1) THE FILE ARRAY
UNLOCKI ; (2) THE FUNCTION TO BUFFER FOR
LDB T,[002100,,BFPRDP] ; (3) IF (2) IS 'READ, THE
PUSH FXP,T ; NUMBER OF HANGING OPEN
MOVEI C,(FXP) ; PARENTHESES
CALLF 3,(AR2A)
SUB FXP,R70+1
HRRZ AR1,-1(P)
JUMPN A,$DEV2D ;NIL MEANS OVER-RUBOUT, ERGO EOF
JSP R,PDLA2-5
JRST $DEV4D
$DEV2D: MOVEI C,(A)
SKIPE V.RSET
CAIN R,QTTYBUF ;DON'T NEED TO CHECK RESULT IF
JRST $DEV2P ; IT WAS OUR OLD FRIEND TTYBUF
MOVEI B,(C)
$DEV2E: JUMPE B,$DEV2P
HLRZ A,(B)
JSP F,TYOARG
HRRZ B,(B)
JRST $DEV2E
$DEV2P: HRRZ AR1,-1(P)
MOVEI TT,FI.BBC
HRRZM C,@TTSAR(AR1)
JSP R,PDLA2-5
HLRZ D,(P)
JRST $DEV0
$DEV4Q: MOVE F,F.MODE(T)
TLNN F,FBT<FU> ;IF TTY DOESN'T HAVE 12.-BIT
JRST $DEV4 ; CHARS, THEN WE ARE WINNING
UNLOCKI
PUSHJ P,INFLUZ ;OTHERWISE WE LOSE
JRST $DEV0
$DEV4: SKIPL F,F.MODE(T) .SEE FBT.CM
JRST $DEV5
HRLM D,(P)
PUSHJ P,TYIF1
HLRZ D,(P)
$DEV4B: JUMPGE TT,$DEV6
$DEV4A: UNLOCKI
$DEV4D: MOVNI TT,1
JUMPE D,CPOPJ ;ONLY PEEKING, SO MERELY RETURN -1
PUSHJ P,EOF ;SIGNAL EOF
JRST $DEVICE ;RETRY IF WE SURVIVE
$DEV4H: SKIPL F,F.MODE(T)
JRST $DEV5 ;BUFFERED TTY INPUT??? OH WELL.
SPECPRO INTTYY
$DEV4J: .CALL $DEV4M ;GOBBLE CHAR, EVEN IF NOT ACTIVATED
NOPRO
.VALUE
MOVE TT,TTSAR(AR1)
SKIPN FT.CNS(TT)
JRST $DEV4K ;DONE IF NO ASSOCIATED OUTPUT TTY
HRLM D,(P)
PUSH P,AR1
HRRZ AR1,FT.CNS(TT)
PUSHJ P,TTYBR1 ;OTHERWISE READ IN NEW CURSORPOS OF TTY
MOVE TT,TTSAR(AR1)
POP P,AR1
HLRZM D,AT.LNN(TT) ;UPDATE CHARPOS AND LINENUM
HRRZM D,AT.CHS(TT)
HLRZ D,(P)
MOVE TT,TTSAR(AR1)
$DEV4K: EXCH T,TT
JRST $DEV4B
INTTYS: HRROS INHIBIT ;PROTECTION ROUTINE FOR $DEV4J
MOVE T,TTSAR(AR1)
JRST $DEV4J
$DEV4M: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
5000,,%TI<ACT> ;READ CHAR EVEN IF NOT ACTIVATOR
,,F.CHAN(T) ;CHANNEL #
402000,,T ;SINGLE CHAR RETURNED HERE
$DEV5F: PUSHJ P,$DEV5K
JRST $DEV4A
$DEV5: SOSGE AB.CNT(T) ;GOBBLE NEXT INPUT CHAR
JRST $DEV5F ;MAY NEED TO GET NEW BUFFER
ILDB TT,AB.BP(T)
$DEV6: JUMPN D,$DEV6B
MOVEI D,(TT)
ANDI D,177+%TXCTL
TRZN D,%TXCTL
JRST .+3
CAIE D,177
TRZ D,140
TRO D,200000
HRLM D,FI.BBC(T)
SETZ D,
$DEV6B: CAIN TT,↑J
AOS AT.LNN(T)
CAIE TT,↑L
JRST $DEV7
SETZM AT.LNN(T)
AOS AT.PGN(T)
$DEV7: SKIPE AR1,VECHOFILES ;SKIP UNLESS ECHO FILES
SKIPN D ;DON'T ECHO PEEKED-AT CHARS
UNLKPOPJ
HRLI AR1,200000 ;LIST OF FILES, NO TTY
HRLM TT,AR2A
PUSH P,AR2A
JSP T,GTRDTB ;GET READTABLE
LDB TT,[220700,,(P)] ;WATCHIT! CHAR COULD BE 12. BITS
PUSHJ P,TYO6 ;PUSH CHAR INTO ALL ECHO FILES
HLRZ TT,(P)
POP P,AR2A
UNLKPOPJ
$DEV5K: MOVE TT,FB.IOT(T) ;ROUTINE TO REFILL INPUT BUFFER
EXCH T,TT
.CALL IOTTTT
.VALUE
EXCH T,TT
CAMN TT,FB.IOT(T)
POPJ P, ;END OF FILE
SUB TT,FB.IOT(T)
TLZ TT,-1
IMULI TT,@FB.BYT(T)
MOVEM TT,AB.CNT(T)
MOVE TT,FB.BFL(T)
SKIPL F.FPOS(T)
ADDM TT,F.FPOS(T)
MOVEI TT,FB.BUF-1(T)
HLL TT,FB.BYT(T)
MOVEM TT,AB.BP(T)
JRST POPJ1
$DEVER: UNLOCKI
SETO TT,
JUMPE D,CPOPJ
PUSH P,CPOPNVJ
MOVEI A,(AR1)
PUSHJ P,NCONS
MOVEI B,Q%TYI
PUSHJ P,XCONS
IOL [CAN'T TYI - FORM(S) PENDING!]
INFGT0: PUSHJ P,INFLUZ
INFGET: SKIPN AR1,VINFILE ;GET VINFILE IN AR1
JRST INFGT0
POPJ P,
INFLZZ: SKIPA T,[[SIXBIT \INFILE CLOSED!\]]
INFLUZ: MOVEI T,[SIXBIT \BAD VALUE FOR INFILE!\]
PUSH P,A
MOVEI A,TRUTH ;INFILE IS A LOSER!
EXCH A,VINFILE
PUSH P,CPOPAJ
%FAC (T)
] ;END OF IFN QIO
SUBTTL READLIST, IMPLODE, MAKNAM
Q% BYTEAC==A
Q$ BYTEAC==TT
MKNR6C: MOVEM T,MKNCH
JSP TT,IRDA
SKIPA
MKR6DB: IDPB BYTEAC,C
PUSHJ P,@MKNCH
Q% JUMPE A,RDAEND
Q$ JRST RDAEND
SOJGE D,MKR6DB
PUSH FXP,BYTEAC
PUSHJ FXP,RDA4
JSP TT,IRDA1
POP FXP,BYTEAC
SOJA D,MKR6DB
IFE QIO,[
READLIST: MOVEI B,MKNAM2 ;SUBR 1
JUMPE A,RDL12 ;MKNAM2 IS JUST THE THING:
JSP T,SPECBIND ;LIKE KRYPTONITE, IT GLOWS COLD GREEN;
Q% 0 B,TYIMAN ;FORCE TYIMAN TO DO OUR WILL,
Q% 0 NIL,TMBBC ;SO READ FROM READLIST GETS ITS FILL!
0 A,MKNM3
MOVEI A,(B)
PUSHJ P,READ0A
SKIPE T,MKNM3
CAIN T,-1
JRST UNBIND
LERR EMS1 ;EXTRA CHARS IN LIST
READ6C: MOVEM A,CORBP ;SAVES F - SEE FSLSTP, ETC.
MOVEI T,R6C1
PUSHJ FXP,MKNR6C
JRST RINTERN
R6C1: ILDB A,CORBP ;GET NEXT CHAR FOR READ6C
SKIPE A
ADDI A,40
POPJ P,
MKNAM2: SKIPE A,TMBBC ;GET NEXT CHAR FOR READLIST
JRST MKNAM7
PUSH FXP,T
PUSH FXP,TT
MKNAM3: SKIPN B,MKNM3
JRST MKNAM6
CAIN B,-1
LERR EMS3 ;NOT ENOUGH CHARS IN LIST
PUSHJ P,MKRL1
JRST PXTTTJ
MKNAM6: MOVEI A,203
HLLOS MKNM3
JRST PXTTTJ
MKNAM7: SETZM TMBBC ;TAKE TYIMAN'S BUFFERED-BACK CHAR THIS TIME
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
READLIST: JUMPE A,RDL12
MOVEI B,RDLTYI
MOVEI C,RDLUNTYI
JSP T,SPECBIND
0 A,RDLARG
0 B,TYIMAN
0 C,UNTYIMAN
;; 0 AR1,READPMAN
;; 0 AR2A,UNREADMAN
MOVEI A,RDIN
PUSHJ P,READ0A
SKIPE T,RDLARG ;REALLY OUGHT TO ALLOW
CAIN T,-1 ; A TRAILING SPACE
JRST UNBIND
LERR EMS1 ;TOO MANY CHARS
;;; READLIST PEEK AND TYI ROUTINES. (CF. $DEVICE).
;;; SAVES A,B,C,AR2A; CLOBBERS AR1. RETURNS CHARACTER IN TT.
RDLPEK: JRST RDLPK1 ;RDLTYI-1 IS FOR PEEKING (SEE TYIPEEK)
RDLTYI: PUSH P,A
SKIPN A,RDLARG
JRST RDLTY2
CAIN A,-1
LERR EMS3 ;TOO FEW CHARS
HRRZ AR1,(A)
MOVEM AR1,RDLARG
RDLTY1: HLRZ A,(A)
RDLTY3: JSP T,CHNV1
JRST POPAJ
RDLTY9: SIXBIT \NOT ASCII CHAR!\
RDLTY2: HLLOS RDLARG
MOVEI TT,203 ;PSEUDO-SPACE
JRST POPAJ
RDLPK1: SKIPE TT,RDLARG
CAIN TT,-1
JRST M1TTPJ ;RETURN -1 FOR PEEKING AT "EOF"
PUSH P,A
HLRZ A,@RDLARG
JRST RDLTY3 ;ELSE RETURN CHAR, BUT DON'T FLUSH
RDLUNTYI: MOVEI TT,(A)
JSP T,FXCONS
HRRZ B,RDLARG
PUSHJ P,CONS
MOVEM A,RDLARG
POPJ P,
READ6C: PUSH FXP,A
MOVEI T,R6C1
PUSHJ FXP,MKNR6C
SUB FXP,R70+1
JRST RINTERN
R6C1: ILDB TT,-1(FXP)
JUMPE TT,CPOPJ
ADDI TT,40
JRST POPJ1
] ;END OF IFN QIO
SUBTTL READ FUNCTION
;;; ********** HIRSUTE READER **********
IREAD: MOVEI T,0
IREAD1: SKIPE VOREAD
JCALLF 16,@VOREAD
OREAD:
IFE QIO,[
JSP R,ORD
QOREAD
READ: MOVEI A,RDIN
AOSE RRDF
JRST READ0 ;OOOPS, A RE-ENTRANT CALL TO READ
SETZM RDOBCT ;OK TO CALL RDIN0 NOW.
PUSHJ P,READ0B ;TOP-LEVEL READ
SETOM RRDF ;RESTORE FLAG INDICATING READ RECURSION
] ;END OF IFE QIO
IFN QIO,[
JSP D,INCALL
QOREAD
READ: MOVEI A,QOREAD ;ENABLE TTY PRE-SCAN
HRLM A,BFPRDP
MOVEI A,RDIN
HRRZ T,BFPRDP
JUMPN T,READ0 ;OOOOPS, A RE-ENTRANT CALL TO READ
PUSHJ P,READ0B ;TOP-LEVEL READ
HLLZS BFPRDP
] ;END OF IFN QIO
SKIPA B,RDBKC
READ0: PUSHJ P,REKRD ;RE-ENTRANT READ
TLC T,21000 ;LOSING SPLICING MACROS AT TOP LEVEL
TLCN T,21000
JRST READ ;JUST GO AROUND AND TRY AGAIN
TLNE B,100000 ;IF WE ENDED WITH A PSEUDO-SPACE
TLNN B,40 ; (40-BIT SET IN SPACE SYNTAX),
TLNN T,60 ; OR IF OBJECT WASN'T AN ATOM,
POPJ P, ; THEN DO NOT BUFFER BACK A CHAR
JSP R,RVRCT ;OTHERWISE MUST UNTYI A CHARACTER
IFN QIO,[
EXCH A,C
PUSHJ P,@UNTYIMAN
JRST CRETJ
] ;END OF IFN QIO
IFE QIO,[
SKIPN TYIMAN
SKIPE TAPRED ;THAT NEEDS TO BE SAVED
JRST READ3
EXCH A,C
MOVE B,RDTYBF
PUSHJ P,CONS ;BACKUP ONE CHAR ON THE BUFFERED TTY
SKIPN RDTYBF
HRLM A,RDTYBF
HRRM A,RDTYBF
JRST SPROG3
READ3: SKIPE TYIMAN
JRST READ3A
MOVE D,UTIBP ;BACK UP ONE CHAR IN THE UTAPE BUFFER
DPB C,D ;AND RE-STORE A "(", OR WHATEVER.
ADD D,[070000,,]
JUMPGE D,.+2
SUB D,[430000,,1]
MOVEM D,UTIBP
10$ AOS UTIBYT
POPJ P,
READ3A: MOVEM C,TMBBC ;BACK UP ONE CHAR ON THE TYIMAN
POPJ P,
] ;END OF IFE QIO
;;; ***** HERE IT IS FANS, THE BASIC READER *****
READ0B: HRRZM A,RDINCH ;READ-IN CHANNEL FILTER
JSP T,RSXST
HRRZ A,VIBASE
IFN USELESS,[
CAIN A,QROMAN
JRST RD0BRM
] ;END OF IFN USELESS
SKIPE V.RSET
JRST RD0B1
MOVE TT,(A)
JRST RD0B2
RD0B1: SKOTT A,FX
JRST IBSERR
MOVE TT,(A)
JUMPLE TT,IBSERR
CAIL TT,200
JRST IBSERR
RD0B2:
IFN USELESS, SETZM RDROMP
RD0B2A: MOVEM TT,RDIBS
BG$ SUBI TT,10.
BG$ MOVEM TT,NRD10FL
MOVSI T,3 ;TOP LEVEL, FIRST OF LIST FLAGS
PUSHJ P,RDOBJ1 ;READ ONE OBJECT
HRRZS A
SETZB C,AR1
MOVEI AR2A,0
POPJ P,
IFN USELESS,[
RD0BRM: MOVEI TT,10.
SETOM RDROMP
JRST RD0B2A
] ;END OF IFN USELESS
RVRCT: MOVE C,VREADTABLE
MOVSI TT,-LRCT+2
CAME B,@TTSAR(C)
AOBJN TT,.-1
JUMPGE TT,ER3 ;BLAST? - READ
MOVEI C,(TT)
JRST (R)
READ0A: PUSHJ P,REKRD
TLNN T,4060
RMCER: LERR EMS5 ;READ MACRO CONTEXT ERROR
POPJ P,
REKRD: SAVE RDINCH RDIBS
PUSHJ P,READ0B
REKRD1: RSTR RDIBS RDINCH
POPJ P,
RDOBJ3:
TLNE B,RS%WSP ;TAB,SPACE,COMMA
JRST RDOBJ1
TLNN T,1
POPJ P,
Q% SKIPE RRDF
Q% JRST RMCER
Q$ HRRZ TT,BFPRDP
Q$ JUMPN TT,RMCER
RDOBJ1: JSP TT,RDCHAR ;*** READ ONE OBJECT ROUTINE ***
RDOBJ: NWTN N,B,OBB ;OBJECT BEGIN CHAR - NOT USAGE AT TYIPEEK
JRST RDOBJ3
Q% SKIPL RDOBCT ;IF READ FROM FILE,
Q% AOS RDOBCT ;ERROR TO CALL RDIN0 NOW.
Q$ MOVSI TT,400000 ;REALLY INTO THE READ NOW
Q$ IORM TT,BFPRDP
TLNE B,RS%MAC
JRST RDOBJM ;MACRO CHAR.
TLNE B,RS%SCO
JRST RDCHO1 ;SINGLE CHAR OBJ.
NWTNE B,RS.<LTR+XLT>
JRST RDALPH ;RDOBJ WILL EXIT WITH OBJECT READ
TLNE B,RS%LP ;IN ACC A, AND RCT ENTRY OF BREAK
JRST RDLST ;CHARACTER IN ACC B
NWTNE B,RS.DIG
JRST RDNUM
NWTNE B,RS.SGN
JRST RDOBJ6 ;+,-
MOVE AR1,B
JSP TT,RDCHAR ;DEFAULT IS . <DOT>
TLNN AR1,RS.PNT
JRST RDOBJ0 ;WAS DOTTED PAIR POINT ONLY
NWTNE B,RS.DIG ;IS NEXT CHAR A DIGIT?
JRST RDOBJ5 ;IF SO, THEN MUST BE FLOATING NUM COMING UP
TLNN AR1,RS%DOT
JRST RDJ2A ;IF NOT DOTTED PAIR, THEN TRY ALPHABETIC
RDOBJ0: TLNE AR1,RS%DOT ;*** DOT IS DOTTED-PAIR DOT ***
TLNE T,1
JRST ER2
TLOE T,4 ;LOSE IF ALREADY IN DOTTED PAIR
JRST ER2
JRST RDOBJ ;SO GET SECOND PART OF DOTTED PAIR
;;;. WITH DECIMAL SYNTAX ONLY TURNS INTO SCO, IF FOLLOWED BY BREAK
;;;OR BEGINNING OF ALPHA IF FOLLOWED BY ALPHA
RDJ2A: TLNN B,RS%<BRK+SCO+WSP+LP+DOT+RP+MAC+SLS+RBO>
NWTNN B,RS.<PNT+ARR+SGN+XLT+LTR>
JRST RDCHO4
JRST RDJ2A1
RDOBJ5: TLOA T,200 ;FOUND FLOATING NUM
RDOBJ2: TLO T,10000 ;NUM FORCED WITH "+"
RDJ2A1: JSP TT,IRDA
IDPB AR1,C
AOS D
JRST RDNUM2
RDOBJ6: JSP TT,IRDA ;PROCESS OBJ BEGINNING WITH + OR -
IDPB B,C
SOS D
NWTNE B,RS.ALT
TLO T,400 ;-
JSP TT,RDCHAR
JRST @RDOBJ8 ;CHECK FOR WHITE'S + HAC, USING RD8W, OR DONT BOTHER, USING RD8N
RDJ6A: TLNE B,RS%<MAC+RP+LP+SCO+WSP>
JRST RDOBJ4
NWTNN B,RS.PNT
JRST ER1
MOVE AR1,B
JSP TT,RDCHAR
TLNE T,4
JRST ER1
JRST RDOBJ5 ;+.D DECIMAL FLOATING FORMAT
RDOBJ7: NWTNE B,RS.DIG
JRST RDNUM2 ;+<DECIMAL DIGIT>
TLO T,20 ;+<ALPHA CHARA> OR +<EXTENDED ALPHA>
JRST RDA1
Q$ ER1: LERR MES2
RDOBJ4: TLO T,20 ;SINGLE CHARA "+" OR "-"
JRST RDBK
RD8W: NWTNE B,RS.<DIG+LTR>
JRST RDOBJ2
JRST RDJ6A
RD8N: NWTNE B,RS.<SGN+DIG+LTR+XLT>
JRST RDOBJ7
JRST RDJ6A
RDNUM: JSP TT,IRDA ;*** NUMBER ATOM ***
RDNUM2:
IFE BIGNUM, SETZM AR1 ;FLAG INDICATES HOW MANY DIGITS BEYOND OVERFLOW
RDNM10: SETZB F,R ;BASE 10. NUMBER IN R, BASE IBASE IN F
TLOA T,40
RDNUM1: JSP TT,RDCHAR
NWTNE B,RS.PNT
JRST RDNUM4 ;DECIMAL POINT [WITHOUT BREAK BIT SET]
SOSLE D
IDPB B,C
NWTNE B,RS.DIG
JRST RDNUM5
TLNE T,300 ;ALPHA CHAR SEEN
JRST RDNUM8
NWTNN B,RS.LTR
JRST RDNUM7
TLNN T,10000
JRST RDNUM6
NW% MOVEI TT,(B) ;GET CHTRAN
NW$ HRRZ TT,B
NW$ ANDI TT,177
CAIL TT,"a ;ALLOW FOR LOWER CASE LETTERS
SUBI B,"a-"A
SUBI B,"A-"0-10. ;LETTERS ARE SUPRA-DECIMAL:
JRST RDNUM5 ; A=10., B=11., ..., Z=35.
RDNUM8:
NW% CAIE A,"E ;UPPER AND LOWER CASE E ALLOWED
NW% CAIN A,"e ;MUST TIDY THIS UP SOMEDAY
NW$ TLNE B,RS%SQX ;EXPONENT OR (SOMEDAY) STRING-QUOTE
JRST RDNM8A
NWTNN B,RS.XLT
JRST ER1
RDNUM7: TLNE T,37000 ;EXTENDED ALPHA CHAR SEEN
JRST ER1
NWTNN B,RS.ARR
JRST RDNUM6
NWTNE B,RS.ALT
TLOA T,2000 ;←
TLO T,1000 ;↑
BG$ SKIPN NRD10FL ;IF WE ARE READING IN BASE 10., THEN
BG$ TLO T,100 ; F HAS NOTHING IN IT - SO MUST TAKE R
RDNUM9: TLNN T,140000
JRST RDNM9E
TLNE T,300 ;FOR EXPONENT-IFIED BIGNUMS, RDNSV WILL
HRR AR2A,AR1 ;BE MEANINGLESS
HRLI AR2A,0
TLNE T,400 ;BIGNUM OF CORRECT BASE AND SIGN IS PUT IN AR2A
TLO AR2A,-1
JRST RDNM9B
RDNM9E: TLNE T,300
MOVE F,R
TLNE T,400
MOVNS F
MOVEM F,RDNSV
RDNM9B: TLZ T,500 ;ZERO OUT SIGN AND DECIMAL BITS
MOVEI D,BYTSWD*LPNBUF
JSP TT,RDCHAR
RDNM9C: NWTNN B,RS.<DIG+SGN>
JRST ER1
NWTNN B,RS.SGN
JRST RDNM10
NWTNE B,RS.ALT ;SKIP IF +
TLO T,400
JSP TT,RDCHAR
JRST RDNM10
RDNUM0: IDPB B,C
RDNUM6: TLZ T,340 ;TWAS REALLY AN ALPHA ATOM
TLO T,20
JRST RDA3
RDNM8A: TLZ T,100
TLO T,1200
MOVEM D,RDDSV
JRST RDNUM9
RDNMF: JRST 2,@[.+1] ;CLEAR OUT ALL ARITHMETIC OVERFLOW BITS
MOVE B,T
MOVE TT,F ;FINISHED WITH NUMBER READ, SO PICK UP NUMBER IN BASE IBASE
BG$ SKIPN NRD10FL
BG$ TLO T,100
TLNN T,300
JRST RDNM2
MOVE TT,R ;PICK UP NUMBER IN BASE 10.
IFE BIGNUM,[
JUMPE AR1,RDNM2 ;NUMBER OF OVERFLOW DIGITS IN AR1
TLNN T,200
JRST RDNMER
ADDM AR1,D
ADDM AR1,RDDSV
]
RDNM2: TLNE T,400
MOVNS TT ;NEGATIVE NUMBER, IF INDICATED
BG$ TLNE T,140000
BG$ JRST RDBIGN
RDNM2A: TLNE T,200
JRST RDFLNM
RDFXNM: TLNE T,3000
JRST RDFXEX
RDFX1: JSP T,FIX1A
RDFL1: MOVE T,B
JRST RDNMX
RDNUM5: JFCL 8.,.+1 ;BASIC LOOP THAT INCREMENTALLY ADDS IN ONE DIGIT
IFE BIGNUM, JUMPN AR1,RDNUMC
IFN BIGNUM,[
TLNE T,40000
JRST RDBG10
]
RDNUMD: MOVE TT,R ;BASE 10. VALUE ACCUMULATES IN R
IMULI R,10. ;BASE IBASE VALUE IN F
NW% ADDI R,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD R,A
JFCL 8,RD10OV
IFN BIGNUM,[
TLNE T,100000 ;BIGNUM VALUE BASE 10. HELD IN AR1
JRST RDBGIB ;BIGNUM VALUE BASE IBASE HELD IN AR2A
RDNUMB: SKIPN NRD10FL
JRST RDNUM1
]
IFE BIGNUM, RDNUMB:
JFCL 8,.+1 ;MIGHT BE SET IF OVFL ON BASE 10. READIN, WENT TO RD10OV, DID A C1CONS,
MOVE TT,F ;DID A GC, HACKED AROUND AND SET IT AGAIN!
IMUL F,RDIBS
NW% ADDI F,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD F,A
JFCL 8,RDIBOV
JRST RDNUM1
IFE BIGNUM,[
RDIBOV: MOVE F,T
MOVE T,TT ;OVERFLOW WHILE ACCUMULATING NUMBER
MUL T,RDIBS ;IN BASE IBASE. TRY TO RECUPERATE
LSH T+1,1 ;TO ALLOW, FOR EXAMPLE, 400000000000
LSHC T,35.
NW% ADDI T,-"0(B)
NW$ ADD T,A
EXCH T,F
JRST RDNUM1
RD10OV: MOVE R,TT
RDNUMC: AOJA AR1,RDNUMB
]
RDFXEX:
IFN BIGNUM, CAIG A,77
TLNE T,600
JRST ER1
EXCH TT,RDNSV
TLNN T,2000
JRST .+3
LSH TT,@RDNSV
JRST RDFX1
IFN BIGNUM,[
SKIPGE TT
TLO T,400
MOVMS TT
RX1: SOSGE RDNSV
JRST RDFX2
TLNE T,100000
JRST RDEX3
]
IFE BIGNUM,[
RX1: SOSGE RDNSV
JRST RDFX1
]
MUL TT,RDIBS
IFN BIGNUM,JUMPN TT,RDEXOF
LSH TT+1,1
LSHC TT,35.
JRST RX1
IFN BIGNUM,[
RDFX2: TLNE T,100000
JRST RDBIGM
TLNE T,400
MOVNS TT
JRST RDFX1
]
RDFLNM: TLNN T,1000
JRST RDFL3
MOVE D,RDDSV
ADD D,TT
AOS D
MOVE TT,RDNSV
RDFL3: HRREI R,-BYTSWD*LPNBUF-1(D)
IFN BIGNUM,[
TLZE T,140000
JRST RDFL3A
]
IDIVI TT,400000
SKIPE TT
TLC TT,254000
TLC TT+1,233000
FADL TT,TT+1
RDFL3A: MOVM T,R
RDFL2A: JUMPGE R,RDL2A2
RDFL2D: SETZ R,
CAIG T,30.
JRST RDL2D3
FSC TT,54. ;SCALE, SO THERE WONT BE UNDERFLOWS
MOVNI R,54.
RDL2D0: FDVL TT,[1.0↑8] ;LOOP FOR MULTIPLYING-IN NEGATIVE POWER OF 10.0
FDVR TT+1,[1.0↑8]
FADL TT,TT+1
SUBI T,8
RDL2D3: CAILE T,8
JRST RDL2D0
JUMPE T,RDFL2E
RDL2D1: FDVL TT,[10.0]
FDVR TT+1,[10.0]
FADL TT,TT+1
SOJG T,RDL2D1
RDFL2E: FADR TT,TT+1
FSC TT,(R)
JFCL 8,RDL2E1
RDL2E0: JSP T,FPCONS
JRST RDFL1
RDL2E1: JSP T,.+1
SKIPE VZUNDERFLOW
TLNN T,100 ;RANDOM FP UNDERFLOW BIT
JRST RDNMER
MOVEI TT,0
JRST RDL2E0
RDL2A0: MOVE TT+2,TT+1 ;LOOP FOR MULTIPLYING-IN POSITIVE POWER OF 10.0
FMPR TT+2,[1.0↑8]
FMPL TT,[1.0↑8]
UFA TT+1,TT+2
FADL TT,TT+2
SUBI T,8
RDL2A2: CAIL T,8
JRST RDL2A0
JUMPE T,RDL2A3
RDL2A1: MOVE TT+2,TT+1
FMPRI TT+2,(10.0)
FMPL TT,[10.0]
UFA TT+1,TT+2
FADL TT,TT+2
SOJG T,RDL2A1
RDL2A3: SETZ R,
JRST RDFL2E
RDLST:
Q$ AOS BFPRDP
PUSH P,T ;*** READ LIST ***
PUSH P,R70 ;POINTER TO LAST OF FORMING LIST
HRLZI T,2
JRST RDLST3
RDLST1: TLZE T,2
JRST RDLS1A
HLR B,(P) ;IFN NEWRD,??
HRRM A,(B)
JRST (TT)
RDLS1A: MOVEM A,(P)
JRST (TT)
RDLST2: PUSHJ P,NCONS
JSP TT,RDLST1
RDLS2A: HRLM A,(P)
RDLS3B: MOVEI T,0
RDLS3A: SKIPA B,AR2A
RDLST3: JSP TT,RDCHAR
PUSHJ P,RDOBJ
TLZE T,4
JRST RDLST4
MOVEM B,AR2A
TLZE T,20000
JRST RDMC
TLNE T,24060 ;EXIT IF NO OBJECT READ
JRST RDLST2
RDLSX: TLNN B,RS%RP
LERR EMS6 ;BLAST, MISSING ")"
POP P,A
POP P,T
Q$ SOS BFPRDP
RDLSX1: MOVSI B,RS%<BRK+WSP> ;THROWAWAY BREAK-CHARACTER
TLO T,4000
POPJ P,
RDMC: TLNN T,4060
JRST RMCER
TLNN T,1000
JRST RDLST2 ;NORMAL MACRO OBJECT
TLZ T,-3
JUMPE A,RDLS3A
JSP TT,RDLST1
JSP AR1,RLAST ;SPLICING MACRO OBJECT
JRST RDLS2A
RDOBJM: TLO T,20000 ;*** MACRO CHARACTER ***
NWTNE B,RS.ALT ;SPLICING?
TLO T,1000 ;SPLICING MACRO
Q% HRR T,RRDF
PUSH P,T
Q% AOS RRDF
SETZM RDBKBF
NW% CALLF 0,(B) ;MACRO CHARACTER HAS LINK IN RH OF
IFN NEWRD,[
LDB D, [001100,,B]
PUSHJ P, GETMAC
HRRZ A, (A)
CALLF 0, (A)
] ;END OF IFN NEWRD
JSP T,RSXST
POP P,T
Q% HRREM T,RRDF
SKIPN B,RDBKBF
JRST RDLSX1
TLO T,60
POPJ P,
RDALPH: TLO T,20 ;*** PNAME ATOM ***
SETOM LPNF
RDA0: JSP TT,IRDA1
RDA1: IDPB B,C
RDA3: JSP TT,RDCHAR
SOJG D,RDA1
MOVEM B,AR2A
PUSHJ FXP,RDA4
MOVE B,AR2A
JRST RDA0
RDA4: PUSHJ P,PNCONS ;ADDS ANOTHER SEGMENT TO A LONG PNAME LIST
AOSN LPNF
PUSH P,R70
MOVE B,(P)
EXCH A,B
PUSHJ P,.NCONC
MOVEM A,(P)
POPJ FXP,
RDLST4: TLNE T,2 ;*** DOT PAIR ***
JRST ER2
TLZ T,60
MOVS TT,(P)
HRRM A,(TT)
TLZE T,20000
JRST RDLS4A
RDLS4B: TLNE B,RS%RP ;RIGHT PAREN?
JRST RDLSX
NWTN E,B,WTH ;SKIP IF NOT WORTHY CHAR
JRST RDLS4C
JSP TT,RDCHAR ;IF CHAR IS UNWORTHY, THEN FLUSH IT AND TRY AGAIN
JRST RDLS4B
RDLS4A: TLZN T,1000
JRST RDLS4B
MOVE AR2A,RCT0+".
JUMPE A,RDLS3B
JSP AR1,RLAST
JRST RDLS2A
RDLS4C: TLNE B,RS%MAC
NWTNN B,RS.ALT
JRST ER2
PUSHJ P,RDOBJM ;SPLICING MACRO
JUMPE A,RDLS4B
HLRZ AR2A,(P)
HRRZ C,(AR2A)
HRRM A,(AR2A)
JSP AR1,RLAST
HRRM C,(A)
HRLM A,(P)
JRST RDLS4B
RLAST: JUMPE A,(AR1)
RLAST1: HRRZ TT,(A)
JUMPE TT,(AR1)
LSH TT,-SEGLOG
SKIPL ST(TT)
JRST RMCER
HRRZ A,(A)
JRST RLAST1
RDCHO1: MOVE AR1,B
NWTNN B,RS.PNT
JRST RDCHO3
JSP TT,RDCHAR ;. AS SCO ALSO HAS DECIMAL PT. SYNTAX
NWTNE B,RS.DIG
JRST RDOBJ5 ;WILL TAKE AS FLOTING PT. NUM
NWTN N,B,WTH ;SKIP IF WORTHY CHAR
JRST RDCHO3 ;CAN TOSS OUT NEXT UNWORTHY CHAR
RDCHO4: PUSH FXP,B ;OTHERWISE, SAVE NEXT CHAR AS IF IT WERE IMPORTANT BREAK CHAR
SKIPA C,[RDCHO2]
RDCHO3: MOVEI C,RDLSX1
MOVE B,AR1
PUSH P,C
RDCHO: JSP TT,IRDA ;*** SINGLE CHARA OBJECT ***
SETZM PNBUF
IDPB B,C
JRST RINTERN
RDCHO2: POP FXP,B ;AFTER MAKING UP . AS SCO,
MOVEM B,RDBKC ;MAKE NEXT CHAR LOOK LIKE
TLO T,20 ;IMPORTANT BREAK CHAR
POPJ P,
IFN BIGNUM,[
RD10OV: TLO T,40000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR1,A
JRST RDBG1A
RDIBOV: TLO T,100000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR2A,A
JRST RDBGIA
RDBG10: TLNE T,3000
JRST RDNUMD ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBG1A: MOVE T,AR1
MOVEI D,-"0(B)
NW$ ANDI D,177
MOVEI TT,10.
PUSHJ P,.TM.PL
MOVE T,TSAVE
TLNE T,100000
JRST RDBGIA
JSP A,RDRGRS
JRST RDNUMB
RDBGIB: TLNE T,3000
JRST RDNUMB ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBGIA: MOVE T,AR2A
MOVE TT,RDIBS
MOVEI D,-"0(B)
NW$ ANDI D,177
PUSHJ P,.TM.PL
JSP A,RDRGRS
JRST RDNUM1
.RDMULP: SKIPA T,A
.TIMER: MOVEI D,0 ;T IS LIST OF DIGITS, TT IS MULTIPLIER,
.TM.PL: HLRZ A,(T) ;D IS CARRY.
MOVE R,(A)
MUL R,TT
ADD R+1,D
TLZE R+1,400000
AOS R
MOVEM R+1,(A)
MOVE D,R
HRRZ A,(T)
JUMPN A,.RDMULP
JUMPE D,CPOPJ
MOVE TT,D
PUSHJ P,C1CONS
HRRM A,(T)
POPJ P,
;;; IFN BIGNUM
RDRGSV: MOVEM T,TSAVE
MOVEM D,DSAVE
MOVEM R,RSAVE
MOVEM F,FSAVE
JRST (A)
RDRGRS: MOVE T,TSAVE
MOVE D,DSAVE
MOVE R,RSAVE
MOVE F,FSAVE
JRST (A)
RDEXOF: TLO T,100000
PUSH FXP,TT+1
PUSHJ P,C1CONS
MOVE B,A
POP FXP,TT
PUSHJ P,C1CONS
HRRM B,(A)
TLNE T,400
TLO A,-1
JRST RX1
RDEX3: PUSH P,A
MOVEM T,TSAVE
MOVE T,A
MOVE TT,RDIBS
PUSHJ P,.TIMER
MOVE T,TSAVE
POP P,A
JRST RX1
RDBIGN: TLNE T,3000
JRST RDBGEX
HRLI A,0 ;CREATE BIGNUM SIGN
TLNE T,400
TLO A,-1
TLNE T,100000
TLNE T,300
JRST RDCBG
HRR A,AR2A
RDBIGM: PUSHJ P,BNTRSZ
MOVE TT,[400000,,0]
JRST RDFX1
PUSHJ P,BNCONS
MOVE B,RDBKC
POPJ P,
;;; IFN BIGNUM
RDBGEX: TLNE T,200
JRST RDBXFL
MOVEI D,1
TLNE T,2000
JRST RDBFSH
JUMPLE TT,RDBGXM
IMUL D,RDIBS ;<BIGNUM>↑(TT)
SOJG TT,.-1
RDBGXM: MOVE TT,D
MOVEM T,TSAVE
HRRZ T,AR2A
PUSHJ P,.TIMER
MOVE A,AR2A
MOVE T,TSAVE
JRST RDBIGM
RDBFSH: LSH D,(TT) ;<BIGNUM>←(TT)
JRST RDBGXM
RDBXFL: ADD TT,RDDSV
SUBI TT,BYTSWD*LPNBUF
MOVE A,AR2A
JRST RDCBG1
RDCBG: TLNN T,300
JRST RDNM2B
HRR A,AR1
TLNN T,200
JRST RDBIGM
HRREI TT,-BYTSWD*LPNBUF-1(D)
RDCBG1: PUSH FXP,TT ;THIS IS THE POWER-OF-TEN EXPONENT
MOVE TT,A
PUSHJ P,FLBIGZ
POP FXP,R
JFCL 8.,RDNMER
JUMPGE A,RDFL3A
DFN TT,TT+1
JRST RDFL3A
RDNM2B: TLZ T,140000 ;A BIGNUMBER BASE 10. WAS REALLY A REGNUM
JRST RDNM2A ;BASE IBASE, BUT BIG ENOUGH TO OVFLO BASE 10. CALC
] ;END OF IFN BIGNUM
SUBTTL READER SINGLE-CHARACTER FILTER
;;; ***** READ ONE CHARACTER (FOR READ) *****
RDCHAR: PUSHJ P,@RDINCH
MOVE B,@RSXTB
RDCH1:
NW% JUMPGE B,(TT)
NW$ NWTNE B,RS%BRK
NW$ JRST (TT)
NWTN E,B,[<SQX+SCO+WSP+LP+DOT+RP+MAC+PNT>]
JRST RDBK ;BREAKING CHAR FOUND
NWTN N,B,WTH
JRST RDCHAR ;WORTHLESS CHAR
TLNN B,RS%SLS
JRST (TT) ;ALPHABETIC CHAR WITH BREAK BIT SOMEHOW SET
PUSHJ P,@RDINCH ;/
NW% HRR B,A ;PUT EXTENDED ALPHABETIC SYNTAX ON THIS CHAR
NW% HRLI B,2
NW$ MOVEI B,RS.XLT(A)
JRST (TT)
RDBK: MOVEM B,RDBKC
TLNN T,60
JRST (TT)
TLNN T,20
JRST RDNUM4
PUSHJ FXP,RDAEND
IFN USELESS, SKIPE RDROMP
IFN USELESS, PUSHJ P,RDROM
PUSHJ P,RINTERN
RDNMX: MOVE B,RDBKC
POPJ P,
RDNUM4: TLNN T,300
TLNN B,200
JRST RDNM4A
PUSHJ P,@RDINCH ;. FOUND
MOVE B,@RSXTB
NWTN N,B,SEE
JRST .-3 ;CONTROL-CHARS ARE IGNORED
MOVEI D,BYTSWD*LPNBUF+1
NWTNE B,RS.DIG
TLOA T,200
TLO T,100
JRST RDCH1
RDNM4A: TLNE B,RS.SGN
TLNN T,3000
JRST RDNMF ;TERMINATES A NUMBER TOKEN, UNLESS A SIGN IS
JRST (TT) ;FOLLOWING AN EXPONENTIATOR
IFN USELESS,[
RDROM: SKIPGE LPNF
SKIPN PNBUF
POPJ P,
PUSH FXP,C
MOVE C,[440700,,PNBUF]
SETZB TT,D
RDROM1: ILDB F,C
JUMPN F,RDROM2
PUSH FXP,T
JSP T,FXCONS
POP FXP,T
SUB FXP,R70+1
JRST POPJ1
RDROM2: SETZ R,
IRP X,,[M,D,C,L,X,V,I]N,,[1000.,500.,100.,50.,10.,5,1]
CAIN F,"X
MOVEI R,N
TERMIN
JUMPE R,RDROM7
ADDI TT,(R)
CAIG R,(D)
JRST RDROM3
REPEAT 2, SUBI TT,(D)
RDROM3: MOVEI D,(R)
JRST RDROM1
RDROM7: POP FXP,C
POPJ P,
] ;END OF IFN USELESS
RDAEND: LSHC B,6
DPB B,[360600,,C]
SETZM B
LSHC B,-6
DPB B,C
SKIPGE LPNF
POPJ FXP,
PUSHJ P,PNCONS ;DESTROYS TT
POP P,B
EXCH A,B
PUSHJ P,.NCONC
POPJ FXP,
IRDA: SETOM LPNF ;INITIALIZE FOR READING PNAME-TYPE ATOM
IRDA1: MOVE C,PNBP
MOVEI D,BYTSWD*LPNBUF
JRST (TT)
IFE QIO,[
RDIN: SKIPE A,TYIMAN ;;; NORMAL READ-IN CHANNEL FILTER
JRST (A)
SKIPN TAPRED
JRST RDIN1
PUSHJ P,URED
RDIN3A: SKIPA A,READ ;READ CONTAINS "RDIN"
POPJ P,
JRST .UEOF
RDIN1: SKIPE B,RDTYBF
JRST RDIN2
PUSHJ P,RDIN0
JUMPN A,RDIN ;IF TAPRED NON-NIL, TRY AGAIN
MOVE B,RDTYBF
RDIN2: HRRZ A,(B)
JUMPE A,.+2
HLL A,B
MOVEM A,RDTYBF
HLRZ A,(B)
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
RDIN: PUSHJ FXP,SAV5M1
PUSHJ P,SAVX5
PUSHJ P,@TYIMAN
MOVEI A,(TT) ;***** GRUMBLE *****
PUSHJ FXP,RST5M1
JRST RSTX5
] ;END OF IFN QIO
SUBTTL BUILT-IN MACRO CHARACTER PROCESSORS
;;; SINGLE QUOTE PROCESSOR:
;;; 'FOO => (QUOTE FOO)
RDQTE: PUSHJ P,READ ;FOR THE WHITE SINGLE-QUOTE HAC
PUSHJ P,NCONS
MOVEI B,QQUOTE
JRST XCONS
;;; SEMICOLON COMMENT PROCESSOR: (SPLICING)
;;; ; -- ANYTHING -- <CR> => NIL, HENCE IGNORED
RDSEMI: PUSHJ P,RDSMI0
JUMPE A,CPOPJ ;OK, FOUND CR
LERR EMS10 ;HMMM, HIT E-O-F BEFORE CR
RDSMI0: MOVNI T,1
PUSH P,T
Q% JSP R,ORD
Q$ JSP D,INCALL
QRDSEMI ;THIS SHOULD NEVER [!!] BE USED
RDSMI1: PUSHJ P,TYI
CAIE A,15 ;CR
JRST RDSMI1
JRST FALSE
;;; VERTICAL BAR PROCESSOR:
;;; |ANYTHING| => /A/N/Y/T/H/I/N/G
;;; I.E. IT IS A SUPER SYMBOL QUOTER (ALMOST LIKE ""'S)
RDVBAR: PUSH FXP,R70
Q% JSP T,RSXST
Q$ JSP T,GTRDTB
MOVEI T,RDVB3
PUSHJ FXP,MKNR6C
SUB FXP,R70+1
JRST RINTERN
RDVB2: SETOM -1(FXP)
RDVB3: PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
Q% CAIN A,↑M
Q$ CAIN TT,↑M
JRST RDVB2
Q% CAIN A,↑J
Q$ CAIN TT,↑J
SKIPN -1(FXP)
JRST RDVB4
SETZM -1(FXP)
JRST RDVB3
RDVB4: SETZM -1(FXP)
Q% CAIN A,"|
Q% JRST FALSE
Q$ CAIN TT,"|
Q$ POPJ P,
Q% SKIPGE T,@RSXTB
Q$ SKIPGE T,@TTSAR(AR2A)
TLNN T,2000
JRST POPJ1
PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
Q% CAIN A,↑M
Q$ CAIN TT,↑M
SETOM -1(FXP)
JRST POPJ1
IFN QIO,[
;;; SPLICING MACRO CHARACTER FUNCTIONS FOR ↑Q AND ↑S.
CTRLQ: MOVEI A,TRUTH
MOVEM A,TAPRED
JRST FALSE
CTRLS: SETZM TTYOFF
JRST TERPRI
] ;END OF IFN QIO
IFE QIO,[
SUBTTL OLD I/O TTY PRESCAN, AND RUBOUT HANDLER
;;; ROUTINE TO READ ONE S-EXP FROM TTY AND FILL UP BUFFER FOR TYIN.
RDIN0: SAVE C AR2A
PUSHJ P,SAVX5
SKIPLE RDOBCT ;ERROR IF ANYTHING SIGNIFICANT READ FROM FILE.
LERR EMS10 ;GOT TO TTY INSIDE S-EXP - READ
RDTIN1: SETZB AR2A,RDTYBF
Q% JSP T,IRD0S3
Q$ JSP T,SAVCIC
JRST RDTIN2
RDTTY: PUSHJ P,RDTTY0
RDIN3B:
MOVE B,@RSXTB
JUMPL B,RDTIN4
RDTIN3: JSP T,RD0A
CRDTTY: JRST RDTTY
RDTIN4: CAIN A,↑M
SKIPN LINMODE
JRST RDTN4A
JUMPG AR2A,RDTFF
MOVEI A,203
JSP T,RD0A
MOVEI A,↑M
JRST RDTFF
RDTN4A: TLNE B,RS%<RBO+FF>
JRST RDTRB ;RUBOUT OR FORCED FEED CHAR
SA$ CAIL A,200
SA$ JRST RDTFF
TLNE B,RS%WSP
JRST RDTSPC
TLNE B,RS%MAC
JRST RDTPM
TLNE B,RS%SCO
JRST RDTPO
TLNE B,RS%<LP+RP>
JRST RDTPR ;PARENS
TLNE B,RS%SLS
JRST RDTSH ;SLASHING CHARACTER, E.G. /
TLNE B,RS%DOT
JRST RDTIN3 ;DOTTED PAIR KIND OF DOT
SA$ CAIN A,325
SA% CAIN A,↑U
JRST RDTN2A
SA$ CAIN A,313
SA% CAIN A,13 ;JPG'S "SOFT" FORM FEED
JRST RDTN5A
SA$ CAIN A,314
SA% CAIN A,14 ;FORM FEED [CONTROL-L]
JRST RDTIN5
JSP T,RD0A ;RANDOM WORTHLESS CHAR
RDTIN2: SKIPN TAPRED
JRST RDTTY ;IF STILL READING FROM TTY, CONTINUE.
SETZB AR2A,RDTYBF ;ELSE, RESTART READING.
SETZM RDOBCT ;WITHDRAW AUTOMATIC PERMIT TO RDIN0.
JRST RD0F
RDTN2A:
10$ OUTSTR [ASCIZ \↑U\]
PUSHJ P,TTYTRP
IFE D10,[
SKIPN TTYDISP .SEE %TNPRT
JRST RDTIN1 ;HAC WONT WORK FOR PRINTING TERMINALS
MOVEI D,RD0S3
PUSHJ P,SRNTYP
MOVEI D,[ASCIZ \⊂E\]
PUSHJ P,SRNTYP
] ;END OF IFE D10
JRST RDTIN1
;;; IFE QIO
RDTPR: TLNE B,RS%LP
AOJA AR2A,RDTPM ;(
SOJG AR2A,RDTIN3 ;)
RDTSPC: JSP T,RDTINX
JSP T,RD0A ;TTY READ SPACE, OR PARENS BALANCE
JUMPG AR2A,RDTTY
RDTX2: MOVEI A,0
SETOM RDOBCT ;OK TO CALL RDIN0 AGAIN.
RD0F: RSTR AR2A C
JRST RSTX5
RDTPO: SKIPN RDTYBF ;SCO TREATED LIKE MACRO UNLESS IT IS ONLY CHAR IN TTY BUFFER
JRST RDTPO1
RDTPM: JSP T,RDTINX
HRRZM A,PBFTY ;TERMINATED TOP-LEVEL ATOM WITH BREAK CHAR OTHER THAN SPACE
MOVEI A,203 ;SO PUT IT BACK, AND SIMULATE A SPACE
RDTFF: JSP T,RD0A
JRST RDTX2
RDTPO1: JSP T,RDTNX1
JRST RDTFF
RDTINX: JUMPG AR2A,RDTIN3
SKIPN RDTYBF
JRST RDTIN3
RDTNX1: SKIPE LINMODE
JRST RDTIN3
MOVEI C,(A)
MOVEI A,LRCT-2
HLRZ A,@RSXTB ;TEST IF TERMINATE ONLY ON FORCE-FEED CHAR
EXCH A,C
JUMPE C,RDTIN3
JRST (T)
;;; IFE QIO
RDTSH: JSP T,RD0A ;SLASH, OR QUOTING CHARACTER
PUSHJ P,RDTTY0
JRST RDTIN3
RDTRB:
NW$ TLNN B,RS%FF
NWTNE B,RS.ALT
JRST RDTFF
SKIPE RDTYBF ;TTY READ RUBOUT
JRST RDTRB1
MOVEI A,LRCT-2
HLRZ A,@RSXTB ;DO END-OF-FILE THING IF RUB OUT BEYOND INPUT
SKIPE EOFRTN
JUMPE A,RDTRB3 ;BUFFER, BUT ONLY IF (STATUS TTYREAD) = NIL
PUSHJ P,TTYTRP
JRST RDTIN1
RDTRB1: PUSHJ P,RD0S
SKIPN RDTYBF
JRST RDTIN1
MOVE B,@RSXTB
HLRZ A,RDTYBF
HLRZ A,(A)
MOVE A,@RSXTB
TLNE A,RS%SLS
JRST RDTRB2 ;RUBBED OUT SLASHIFIED CHARA
TLCN B,RS%<LP+RP>
JRST RDTTY
TLNE B,RS%LP
AOJA AR2A,RDTTY
SOJA AR2A,RDTTY
RDTRB2: PUSHJ P,RD0S
JRST RDTTY
RD0A: MOVEM B,C
PUSHJ P,NCONS ;ADD CHARA TO TTY BUF LIST
SKIPN B,RDTYBF
JRST RD0A1
MOVSS B
HRRM A,(B)
HRLM A,RDTYBF
RD0A2: MOVE B,C
JRST (T)
RD0A1: HRLS A
MOVEM A,RDTYBF
JRST RD0A2
RDTTY0: SKIPE A,TYIMAN
JRST (A)
JRST TYIN
;;; IFE QIO
RD0S: MOVE B,RDTYBF ;DELETE CHARA OF END OF TTY BUF LIST
HLRZ A,B ;LEAVES RUBBED OUT CHAR IN A
CAIE A,(B)
JRST RD0S1A
SETZM RDTYBF
HLRZ A,(B)
RD0S2:
IFN D10, JRST TTYECO
IFE D10,[
SKIPE D,TTYDISP
TLNN D,%TOERS
JRST TTYECO
TLNN D,%TOMVU
JRST TTYECO
CAIN A,177 ;RUBOUT DOESN'T PRINT, HENCE NO NEED TO WIPE OUT
POPJ P,
JRST RD0S5 ;GOODIES TO RE-POSITION CURSOR AND RUB OUT!
] ;END OF IFE D10
RD0S1: MOVEI B,(C)
RD0S1A: HRRZ C,(B)
CAIE C,(A)
JRST RD0S1
HLRM C,(B)
HRLM B,RDTYBF
HLRZ A,(C)
JRST RD0S2
RDTN5A: PUSHJ P,TTYTRP ;CONTROL-K FEATURE
JRST RDTN5B
RDTIN5: SKIPN TTYDISP ;CONTROL-L FEATURE
PUSHJ P,TTYTRP
PUSHJ P,CLRSRN
RDTN5B:
JSP T,IRD0S3 ;INITIALIZE SLOT WHERE TTY ECHO IS KNOWN TO BEGIN
PUSH P,CRDTTY
RDTN5C: HRRZ A,RDTYBF ;SPLAT OUT THE RDTYBF AS IT STANDS
MOVEI B,QTTYECO ;USED AS A KIND OF PROGRAMED ECHO
JRST .MAP+2
;;; IFE QIO
IFN D10,[
TTYECO: CAIN A,33 ;DEC LOSES ALTMODES
JRST OUT$
OUTCHR A
POPJ P,
IRD0S3: JRST (T)
CLRSRN: POPJ P,
TTYTRP: OUTSTR [ASCIZ \
\]
POPJ P,
OUT$: OUTCHR .+1
POPJ P,"$
] ;END OF IFN D10
IFE D10,[
TTYECO: CAIN A,20
JRST ECOCNP
MOVEI D,CNPRBR ;CONTROL-P RIGHT-BRACKET
SKIPE TTYDISP
CAIE A,15 ;CR
JRST RTECO
PUSHJ P,SRNTYP
JRST RTECO
ECOCNP: .IOT TYOC,A ;RIGHT WAY TO ECHO ↑P IS
.IOT TYOC,C120 ; AS "↑P P" - ITS DOES THE REST
POPJ P,
RTECO: .IOT TYOC,A
C136: POPJ P,136
IRD0S3: SKIPN TTYDISP .SEE %TNPRT
JRST (T) ;CAN HAC FOR PRINTING TERMINALS
.CALL RCPSBK ;SAVE CURSOR VERTICAL POSITION SO THAT WE WILL
.VALUE ; KNOW WHERE TO BEGIN A COMPLETE ECHO REPRINT
HLRZS D
ADDI D,10
LSH D,29.
MOVEM D,RD0S3+1
JRST (T)
CLRSRN: SKIPN TTYDISP
POPJ P,
MOVEI D,CNPC ; ↑P C
JRST SRNTYP
CNPC: ASCIZ \⊂C\
TTYTRP: .IOT TYOC,C15
C120: POPJ P,120
RD0S5: .CALL RCPSBK ;GET TTY CURSOR POSITION
.VALUE
MOVEI D,(D) ;IF CURSOR IS NOT AT LEFT MARGIN
JUMPE D,RD0S4 ;CAN SIMPLY BACKSPACE
MOVEI D,CNPRB1 ; ↑P B ↑P RIGHT-BRACKET
CAIN A,11
JRST RD0S4 ;FOR LOSING TABS MUST ALSO REDISPLAY
CAIL A,40 ;CONTROL CHARS TAKE TWO POSITIONS
JRST RD0S5A
CAIE A,33 ;EXCEPT ALTMODE
MOVEI D,CNPRB2 ; ↑P B ↑P B ↑P RIGHT-BRACKET
RD0S5A: CAIN A,12 ;LINE FEEDS ARE REALLY STRANGE
MOVEI D,CNPRU1 ; ↑P U ↑P RIGHT-BRACKET
CAIN A,10 ;SO ARE BACKSPACES
MOVEI D,CNPFWD ; ↑P F RUBOUT
CAIE A,37 ;↑← REQUIRES REDISPLAY
JRST SRNTYP
RD0S4: MOVEI D,RD0S3 ;OTHERWISE, MUST TRY TO RE-POSITION
PUSHJ P,SRNTYP ; CURSOR, AND RE-TYPE INPUT BUFFER.
PUSH P,A
PUSHJ P,RDTN5C
MOVEI D,CNPRBR ;↑P RIGHT-BRACKET
PUSHJ P,SRNTYP
JRST POPAJ
CNPRBR: ASCIB [⊂)]
CNPRB1: ASCIB [⊂B⊂)]
CNPRB2: ASCIB [⊂B⊂B⊂)]
CNPRU1: ASCIB [⊂U⊂)]
CNPFWD: ASCIB [⊂F?]
] ;END OF IFE D10
] ;END OF IFE QIO
IFN QIO,[
SUBTTL NEWIO TTY PRESCAN, RUBOUT HANDLER, AND READLINE
;;; INITIAL TTY CHARACTER BUFFERING ROUTINE.
;;; BUFFERS UP A LIST OF CHARACTERS FOR TTY INPUT.
;;; HANDLES ALL APPROPRIATE RUBOUT PROCESSING.
;;; ARGUMENTS ARE A TTY INPUT FILE ARRAY IN A,
;;; THE FUNCTION TO BUFFER FOR IN B (E.G. QOREAD),
;;; AND THE COUNT OF UNMATCHED LEFT PARENS IN C.
;;; RUBOUT ECHOING IS PERFORMED ON THE ASSOCIATED OUTPUT
;;; TTY, IF ANY. HAIRY ERASING RUBOUT IS DONE FOR DISPLAYS.
;;; NO RUBOUT HACKING IS DONE IF THERE IS NO ECHO FILE.
TTYBUF: JSP T,SPECBIND
VECHOFILES
0 A,VINFILE
CAIN A,TRUTH
HRRZ A,V%TYI
PUSH FXP,(C)
CAIE C,QOREAD
SETZM (FXP)
JSP T,GTRDTB ;GET READTABLE;AR2A 4.9 = USEFULP
CAIN B,Q%READLINE ;AR2A 4.9 => USEFULP
TLO AR2A,200000 ;AR2A 4.8 => READLINE
MOVEI TT,FT.CNS ;GET ASSOCIATED OUTPUT TTY
SKIPE C,@TTSAR(A) ; (THE SIGN BIT TELLS TYO6 THIS IS ONE FILE)
PUSHJ P,TTYBRC ;MAYBE GET CURCOR POSITION IN D
TTYB0: PUSH FXP,D
PUSH FXP,-1(FXP) ;PARENS COUNT
MOVEI TT,F.MODE
MOVE R,@TTSAR(AR1) ;GET INPUT FILE MODE BITS
PUSH FXP,R
PUSH FXP,XC-1 ;PUSH -1 (NOT IN STRING YET)
SETZ B, ;B HOLDS LIST OF CHARACTERS
PUSH P,BFPRDP
HRRZS BFPRDP ;WE WANT NO CLEVERNESS FROM $DEVICE
;STATE OF THE WORLD:
; B HAS LIST OF BUFFERED CHARS (IN REVERSE ORDER)
; C HAS TTY OUTPUT FILE ARRAY
; AR2A HAS READTABLE
; 4.9 => USEFUL CHAR SEEN
; 4.8 => READLINE INSTEAD OF READ
; VINFILE HAS TTY INPUT FILE ARRAY
; P: OLD CONTENTS OF BFPRDP
; FXP: STRING TERMINATOR CHAR (-1 IF NOT IN STRING)
; MODE BITS FOR INPUT FILE
; PARENTHESIS COUNT
; SAVED CURSOR POSITION
; ORIGINAL PARENS COUNT
TTYB1: PUSHJ P,TTYBCH ;GET A CHARACTER
MOVE D,@TTSAR(AR2A) ;GET READTABLE SYNTAX
MOVE R,-1(FXP) ;GET MODE BITS
CAIE TT,↑M
JRST TTYB7
TLNE AR2A,200000 ;CR TERMINATES READLINE
JRST TTYB9
TLNN R,FBT<LN> ;SKIP IF LINE MODE
JRST TTYB2
MOVEI TT,203 ;PSEUDO-SPACE
TLNN AR2A,200000 ;SKIP IF HACKING A STRING
JSP R,TTYPSH ;ELSE PUSH CHAR ONTO BUFFER
MOVEI TT,↑M
JRST TTYB9 ;ALL DONE
TTYB7: CAIE TT,↑K ;FOR A ↑K, WE TERPRI
JRST TTYB7F ; AND THEN RETYPE THE BUFFER
TTYB7E: SKIPN AR1,C
JRST TTYB1
PUSHJ P,ITERPRI
JRST TTYB7N
TTYB7F: CAIE TT,↑L ;FOR ↑L, WE CLEAR THE SCREEN,
JRST TTYB2 ; THEN RETYPE THE BUFFER
SKIPN AR1,C
JRST TTYB1
MOVEI TT,F.MODE
MOVE R,@TTSAR(AR1)
TLNN R,FBT<CP> ;IF WE CAN'T CLEAR THE SCREEN,
JRST TTYB7E ; WE JUST MAKE LIKE ↑K
PUSHJ P,CLRSRN
TTYB7N: MOVEI TT,F.CHAN ;READ THE TTY CURSOR POSITION
.CALL RCPOS ;(MAYBE WE SHOULD FORCE BUFFER?)
.VALUE ;*** MAYBE AN IOJRST HERE
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
TLNE F,FBT<EC>
MOVE D,R
MOVEM D,-3(FXP)
PUSHJ P,TTYBLT ;ZAP OUT TTY BUFFER
JRST TTYB1
TTYB2: TLNN AR2A,200000 ;READLINE IGNORES SLASHES
TLNN D,2000 .SEE SYNTAX ;SLASH
JRST TTYB4
JSP R,TTYPSH
PUSHJ P,TTYBCH
TLO TT,400000 ;SLASHIFIED CHAR
TTYB3: TLO AR2A,400000 ;USEFUL FROB SEEN
TTYB3A: JSP R,TTYPSH
JRST TTYB1
TTYB4: TLNE D,1000 .SEE SYNTAX ;RUBOUT
TLNE D,40 .SEE SYNTAX ;NOT SECOND CHOICE
JRST TTYB5
JUMPN B,TTYB4C
HRRZ T,BFPRDP
JUMPE T,TTYB9J ;RETURN TO CALLER FOR EOF
SKIPE AR1,C ;OOPS! INSIDE READ ALREADY!
PUSHJ P,ITERPRI ; WE MUST SIMPLY TERPRI
JRST TTYB1 ; (IF POSSIBLE) AND TRY IT AGAIN
TTYB4C: PUSHJ P,RUB1CH ;RUB OUT CHAR
SKIPL TT,(A) ;SKIP IF CHAR WAS SLASHIFIED
JRST TTYB4G
PUSHJ P,RUB1CH ;RUB OUT SLASH TOO
JRST TTYB1
TTYB4G: SKIPL (FXP) ;SKIP UNLESS IN STRING
JRST TTYB4J
TLNE TT,100000
JRST TTYB4M
MOVE D,@TTSAR(AR2A) ;GET CHARACTER SYNTAX
TLNE D,40000 .SEE SYNTAX ;OPEN PAREN
SOS -2(FXP)
TLNE D,10000 .SEE SYNTAX ;CLOSE PAREN
AOS -2(FXP)
JRST TTYB1
TTYB4J: TLNE TT,200000 ;RUBBED OUT BACK OUT OF STRING
SETOM (FXP)
JRST TTYB1
TTYB4M: HRRZM TT,(FXP) ;RUBBED OUT BACK INTO A STRING
JRST TTYB1
TTYB5: TLNE AR2A,200000 ;GO BACK AROUND IF READLINE
JRST TTYB3A
SKIPGE R,(FXP) ;SKIP IF IN STRING
JRST TTYB5H
CAIE R,(TT)
JRST TTYB3A
TLO TT,100000 ;MARK AS STRING END
SETOM (FXP)
JRST TTYB3A
TTYB5H: TLNE D,1000 .SEE SYNTAX ;FORCE FEED
TLNN D,40 .SEE SYNTAX ;SECOND CHOICE
JRST TTYB5K
TTYB9: JSP R,TTYPSH
JUMPE C,TTY9B
PUSHJ P,TTYBRC
MOVEI TT,AT.LNN ;UPDATE LINENUM AND CHARPOS
HLRZM D,@TTSAR(C) ; OF ASSOCIATED OUTPUT FILE
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(C)
TTY9B: MOVEI A,(B)
PUSHJ P,NREVERSE
MOVEI B,(A)
MOVEI C,(A)
TTYB9D: JUMPE C,TTYB9J
HLRZ A,(C)
MOVE TT,(A)
TLZE TT,-1
JSP T,FXCONS
HRLM A,(C)
HRRZ C,(C)
JRST TTYB9D
TTYB9J: SUB FXP,R70+5
POP P,BFPRDP ;RESTORE BFPRDP
MOVEI A,(B)
JRST UNBIND
TTYB5K: TLNN D,100000 .SEE SYNTAX ;SPACE
JRST TTYB6
TTYB5M: JSP T,TTYATM
JSP R,TTYPSH
JRST TTYB1
TTYB6: TLNN D,200000 .SEE SYNTAX ;SINGLE CHAR OBJECT
JRST TTYB6C
TLO AR2A,400000 ;USEFUL THING SEEN
JRST TTYB5M
TTYB6C: MOVEI R,(D)
MOVEI F,↑M
CAIN R,QRDSEMI
JRST TTYB6F
MOVEI F,(TT)
CAIE R,QRDVBAR
JRST TTYB6J
TLO AR2A,400000 ;USEFUL FROB SEEN
TTYB6F: JSP T,TTYATM
TLO TT,200000 ;STRING BEGIN
MOVEM F,(FXP)
JRST TTYB3
TTYB6J: TLNN D,40000 .SEE SYNTAX ;OPEN PAREN
JRST TTYB6Q
AOS -2(FXP)
JRST TTYB3
TTYB6Q: TLNN D,10000 .SEE SYNTAX ;CLOSE PAREN
JRST TTYB8
JSP T,TTYATM
SOSG -2(FXP)
JRST TTYB9
JRST TTYB3
TTYB8: TLNE D,277237 .SEE SYNTAX ;SKIP IF NOT WORTHY CHAR
JRST TTYB3
JRST TTYB3A
;;; IFN QIO
RCPOS: SETZ
SIXBIT \RCPOS\ ;READ CURSOR POSITION
,,@TTSAR(AR1) ;TTY CHANNEL #
2000,,D ;MAIN PROGRAM CURSORPOS
402000,,R ;ECHO AREA CURSORPOS
TTYBRC: HRROS AR1,C ;GET CURSOR POSITION IN D
TTYBR1: MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
MOVEI TT,F.CHAN ;C HAS OUTPUT FILE FOR ECHOING
.CALL RCPOS ;READ CURSOR POSITION INTO D
.VALUE
TLNE F,FBT<EC>
MOVE D,R ;MAYBE NEED ECHO AREA CURSOR
POPJ P,
TTYPSH: JSP T,FXCONS ;PUSH CHAR IN TT ON FRONT
PUSHJ P,CONS ; OF LIST OF BUFFERED CHARS
MOVEI B,(A)
JRST (R)
TTYATM: JUMPGE AR2A,(T) ;DECIDE WHETHER WE MAY HAVE
MOVE R,-1(FXP) ; TERMINATED A TOP LEVEL ATOM,
SKIPG -2(FXP) ; AND IF SO GO TO TTYB9 AND OUT
TLNE R,FBT<LN+FR> ;WE HAVE *NOT* TERMINATED IF:
JRST (T) ; NO USEFUL CHARS SEEN YET
; ; OPEN PARENS ARE HANGING
; ; TTY INPUT IS IN LINE MODE
; ; (STATUS TTYREAD <FILE>) = NIL
JRST TTYB9
TTYBCH: PUSHJ P,$DEVICE ;GOBBLE A CHARACTER
TRZ TT,%TX<TOP+SFL+SFT+MTA> ;FOLD TO 7 BITS
TRZN TT,%TX<CTL>
POPJ P,
CAIE TT,177
TRZ TT,140
MOVEI D,(TT) ;ATTEMPT TO FLUSH INTERRUPT CHARS
ROT TT,-1
ADDI TT,FB.BUF ;REALLY SHOULD BE MORE CLEVER
HRRZ AR1,VINFILE
HLRZ R,@TTSAR(AR1)
SKIPGE TT
HRRZ R,@TTSAR(AR1)
JUMPN R,TTYBCH
MOVEI TT,(D)
POPJ P,
TTYBLT: SKIPN AR1,C
POPJ P,
MOVEI A,(B) ;TYPE OUT ALL BUFFERED CHARS
PUSHJ P,NREVERSE ; ONTO THE ECHO OUTPUT FILE
MOVEI B,(A)
SKIPG -4(FXP) ;IF WE ENTERED WITH HANGING
JRST TTYBL1 ; PARENS, PRINT THEM
PUSH FXP,-4(FXP)
TTYBL4: MOVEI TT,"(
PUSHJ P,TYOFIL
SOSLE (FXP)
JRST TTYBL4
SUB FXP,R70+1
MOVEI TT,40
PUSHJ P,TYOFIL
TTYBL1: JUMPE B,TTYBL2 ;ECHO ALL CHARS TO ECHO TTY
HLRZ C,(B)
HRRZ TT,(C)
PUSHJ P,TYOFIL
HRRZ B,(B)
JRST TTYBL1
TTYBL2: PUSHJ P,NREVERSE
MOVEI B,(A) ;RESTORE BACKWARDS LIST OF CHARS
MOVE C,AR1 ;RESTORE C (NREVERSE CLOBBERED)
POPJ P,
;;; IFN QIO
RUBOUT: MOVEI D,QRUBOUT ;LSUBR (1 . 2)
CAMGE T,XC-2
JRST WNALOSE
JUMPE T,WNALOSE
CAME T,XC-2
SKIPA AR1,V%TYO
POP P,AR1
POP P,A
JSP F,TYOARG
MOVEI A,(TT)
PUSHJ P,TOFLOK
PUSHJ P,RUB1C1
JRST UNLKTRUE
SETZ A,
UNLKPOPJ
RUB1CH: HLRZ A,(B) ;DELETE CHAR FROM BUFFERED LIST
HRRZ B,(B)
JUMPE C,CPOPJ ;THAT'S IT IF NO ECHO FILE
PUSH P,A
HRRZ A,(A) ;GET CHARACTER IN A
MOVEI AR1,(C)
PUSHJ P,RUB1C1
JRST POPAJ
PUSHJ P,RSTCUR ;MUST RETYPE WHOLE STRING IN PLACE
PUSHJ P,TTYBLT
PUSHJ P,CNPL
JRST POPAJ
RSTCUR: HLLZ D,-3(FXP) ;RESTORE SAVED CURSOR POSITION
HRRI D,"V-10
PUSHJ P,RSTCU3
HRLZ D,-3(FXP)
HRRI D,"H-10
RSTCU3: ADD D,R70+10
JRST CNPCOD
;;; ROUTINE WHICH ATTEMPTS TO RUB OUT A CHARACTER ON A TTY.
;;; SKIPS ON *FAILURE* TO RUB IT OUT.
;;; OUTPUT TTY FILE ARRAY MUST BE IN AR1.
RUB1C1: MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
TLNE F,FBT<SE> ;IF CAN'T SELECTIVELY ERASE
TLNN F,FBT<CP> ; AND MOVE CURSOR AROUND FREELY,
JRST TYOFA ; MERELY ECHO RUBBED-OUT CHAR
CAIN A,177 ;RUBOUT DOESN'T PRINT, HENCE NEEDN'T KILL
POPJ P,
MOVEI T,1
CAILE A,↑← ;CHARS FROM 40 TO 176 ARE ONE
JRST RUB1C3 ; POSITION WIDE, SO BACK UP AND ERASE
CAIN A,↑I ;TABS ARE VARIABLE - MUST RETYPE
JRST POPJ1
CAIN A,↑J ;LINE FEED IS DOWNWARD MOTION -
JRST CNPU ; ERASE BY MOVING UP
CAIN A,↑H ;BACKSPACE IS ERASED BY
JRST CNPF ; MOVING FORWARD
CAIE A,↑M ;FOR CR, DON'T KNOW LENGTH OF PREVIOUS LINE
CAIN A,↑← ;FOR ↑←, MAY OR MAY NOT HAVE BEEN DOUBLED
JRST POPJ1
CAIE A,33 ;ALTMODE IS ALWAYS 1 WIDE
TLNE TT,FBT<SA> ;OTHER CONTROLS ONE WIDE IF IN SAIL MODE
JRST RUB1C3
MOVEI T,2 ;OTHERWISE CONTROL CHARS ARE TWO WIDE
RUB1C3: MOVEI TT,F.CHAN
.CALL RCPOS
.VALUE
TLNE F,FBT<EC>
MOVE D,R
MOVEI R,(T)
CAILE T,(D)
PUSHJ P,CNPU
CAIE R,2
JRST CNPBL
JRST CNPBBL
;;; IFN QIO
;;; READLINE TAKES STANDARD FILE/EOF INPUT ARGUMENTS AND READS
;;; ONE LINE FROM A FILE. IT INVOKES PRE-SCANNING FOR TTY'S.
;;; THE RESULT IS RETURNED AS AN ATOMIC SYMBOL, EXCLUDING THE
;;; CARRIAGE RETURN WHICH TERMINATES THE LINE. LINE FEEDS
;;; ARE IGNORED (NECESSARY FOR SUCCESSIVE READLINE'S).
%READLINE: JSP D,INCALL
Q%READLINE
MOVEI A,Q%READLINE
HRLZM A,BFPRDP ;PERMIT TTY PRE-SCAN
MOVEI T,%RDLN5
PUSHJ FXP,MKNR6C ;PART OF MAKNAM
JRST PNGNK1 ;CREATE NON-INTERNED SYMBOL
%RDLN5: PUSH FXP,D
%RDLN6: PUSHJ P,@TYIMAN
CAIN TT,↑J ;IGNORE LINE FEEDS
JRST %RDLN6
POP FXP,D
CAIN TT,↑M ;CR TERMINATES
POPJ P,
MOVEI A,(TT)
JRST POPJ1
] ;END OF IFN QIO
SUBTTL HAIRY READER BIT DESCRIPTIONS
;OBJECT FLAGS - AS AN OBJECT ACCUMULATES, THE LH OF ACC T
; HAS BITS SET TO DESCRIBE THE STATE OF THE OBJECT
;BIT VALUE MEANING
;3.1 1 TOP LEVEL OBJECT
;3.2 2 FIRST OBJECT OF A LIST
;3.3 4 DOTTED PAIR OBJECT - SECOND HALF
;3.4 10 DELAYED DOT READ
;3.5 20 ALPHA ATOM (I.E., NON-NUMBER ATOM)
;3.6 40 NUMBER ATOM
;3.7 100 DECIMAL NUMBER
;3.8 200 FLOATING NUMBER
;3.9 400 NEGATIVE NUMBER
;4.1 1000 EXPONENT-MODIFIED NUMBER, E.G. ↑ OR E (OR SPLICING, IF MACRO)
;4.2 2000 LSH-ED NUMBER, I.E. ←
;4.3 4000 LIST-TYPE OBJECT
;4.4 10000 SIGNED NUMBER ATOM, E.G. +A
;4.5 20000 MACRO-PRODUCED OBJECT
;4.6 40000 BIGNUM BASE 10.
;4.7 100000 BIGNUM BASE IBASE
;CHARACTER FLAGS - THE RH OF AN ENTRY IN THE RCT TABLE
; GENERALLY HAS THE ASCII TRANSLATION FOR THE CHARACTER,
; EXCEPT MACRO-CHARACTERS, WHICH HOLD A FUNCTION TO EXECUTE
; THE LH HAS DESCRIPTOR BITS AS FOLLOWS:
;BIT VALUE MEANING
;3.1 1 ALPHABETIC, I.E. A,B,C,...,Z
;3.2 2 EXTENDED ALPHABETIC, E.G., !,",#,$, ETC. AND LOWERCASE
;3.3 4 DECIMAL DIGIT, I.E. 0,1,2,...,9
;3.4 10 + OR -
;3.5 20 ↑ OR ←
;3.6 40 SECOND CHOICE DENOTER FOR 3.4, 3.5, 4.1, AND 4.3
;3.7 100 PRINT SHOULD SLASHIFY IF NOT FIRST CHAR
;3.8 200 . <DECIMAL POINT> KIND OF DOT
;3.9 400 PRINT SHOULD SLASHIFY WHEN IN FIRST POSITION
;4.1 1000 THE RUBOUT CHARACTER, OR THE TTY FORCE FEED CHAR
;4.2 2000 THE READ "QUOTE" CHARACTER, I.E. /
;4.3 4000 MACRO CHARACTER, E.G. ', OR SPLICING MACRO
;4.4 10000 )
;4.5 20000 . <DOTTED-PAIR> KIND OF DOT
;4.6 40000 (
;4.7 100000 <SPACE> OR <TAB> OR <COMMA>
;4.8 200000 CHARACTER OBJECT
;4.9 400000 WORTHLESS CHARACTERS, AND ANY WITH BIT 3.8
; OR BITS 4.1-4.8 ON.
PGTOP RDR,[HIRSUTE READER, MAKNAM, ETC.]
;;@ END OF READER 92
;;@ ARRAY 48 ARRAY PACKAGE
PGBOT ARA
SUBTTL ARRAY PACKAGE
IFN JOBQIO, QJOB ;THESE ENTRIES USED ONLY
IFN QIO, QFILE ; BY ARRAYDIMS FUNCTION
ARYTP1: AS<RDT+FX>,,QREADTABLE ;READTABLE
AS<OBA+SX+GCP>,,QOBARRAY ;OBARRAY
NPARTP==.-ARYTP1 ;# OF PECULIAR ARRAY TYPES
AS<SX+GCP>,,TRUTH ;S-EXPRESSION
AS<FX>,,QFIXNUM ;FIXNUM
AS<FL>,,QFLONUM ;FLONUM
AS<SX>,,NIL ;NSTORE-TYPE
LARYTP==.-ARYTP1
ARYTYP==ARYTP1-7 ;FOR JFFO'S ON THE BITS
;;; TABLE OF EXTRA INSTRUCTIONS FOR ARRAY HEADER.
;;; ENTRIES ARE ZERO IF NO INSTRUCTION NEEDED.
ARYIN1: 0 ;READTABLE
0 ;OBARRAY
0 ;S-EXPRESSION
PUSH P,CFIX1 ;FIXNUM
PUSH P,CFLOAT1 ;FLONUM
0 ;NSTORE-TYPE
IFN .-ARYIN1-LARYTP, WARN [ARYIN1 WRONG LENGTH]
;;; TABLES OF INSTRUCTIONS FOR CALLING ARRAY SUBSCRIPT
;;; CALCULATION ROUTINES. DIMSTB IS FOR S-EXPRESSION
;;; ARRAYS, AND DIMFTB FOR FULL-WORD ARRAYS.
DIMSTB: JSP TT,1DIMS ;TABLE OF <N>DIMS'S
JSP TT,2DIMS
JSP TT,3DIMS
JSP TT,4DIMS
JSP TT,5DIMS
DIMFTB: JSP TT,1DIMF ;TABLE OF <N>DIMF'S
JSP TT,2DIMF
JSP TT,3DIMF
JSP TT,4DIMF
JSP TT,5DIMF
SUBTTL ARRAY AND *ARRAY FUNCTIONS
TTDEAD=BPURPG(TT)
TTDEDC=TTDEAD+<TTS<CN>,,>
ARRAY: JSP TT,FWNACK ;FSUBR
FA234567,,QARRAY
JSP TT,KLIST ;LIKE *ARRAY, BUT FIRST TWO
SUBI T,2 ; ARGS NOT EVALUATED
JRST ARRY0
%%ARRAY: JSP TT,LWNACK ;LSUBR (2 . 7)
LA234567,,Q%%ARRAY
ARRY0: MOVEI TT,(P)
ADDI TT,(T) ;TT POINTS TO BELOW ARGS ON PDL
HRRZ A,2(TT)
ARRY0B: MOVSI F,-LARYTP ;CHECK OUT ARRAY TYPE
ARRY0C: HRRZ B,ARYTP1(F)
CAIN B,(A)
JRST ARRY0F
AOBJN F,ARRY0C
WTA [BAD ARRAY TYPE - *ARRAY!]
MOVEM A,2(TT)
JRST ARRY0B
ARRY0F: TLZ F,-1 ;F HAS ARRAY TYPE (INDEX INTO ARYTP1)
CAIL F,NPARTP ;SKIP IF PECULIAR ARRAY TYPE
JRST ARRY2
CAML T,XC-3
JRST ARRY1
ARRY0G: MOVEI D,Q%%ARRAY ;WRONG NUMBER OF ARGS - LOSEY LOSEY
JRST WNALOSE
ARRY1: HRRZ AR2A,ARRYQ1(F) ;DEFAULT ARRAY TO COPY FROM
CAML T,XC-2
SOJA T,ARRY1F ;T REFLECTS # OF DIMS
POP P,A ;GET THIRD ARG
ARRY1A: HLRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF NIL
JUMPE A,ARRY1F
HRRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF T
CAIN A,TRUTH
JRST ARRY1F
MOVEI C,(A) ;THIRD ARG BETTER BE AN ARRAY ITSELF
MOVEI D,(T)
PUSHJ P,AREGET ; TO COPY NEW ONE FROM
MOVEI T,(D)
HLLZ TT,ARRYQ1(F) ;SUPPLIED ARRAY BETTER BE
TDNE TT,ASAR(A) ; OF CORRECT TYPE
JRST ARRY1D
MOVEI A,(C)
%WTA ARRYQ0(F) ;IF NOT, LOSEY LOSEY
JRST ARRY1A
ARRYQ0: SIXBIT \NOT READTABLE - *ARRAY!\
SIXBIT \NOT OBARRAY - *ARRAY!\
ARRYQ1: AS<RDT>,,VREADTABLE ;REQUIRED BIT,,NO ARG DEFAULT
AS<OBA>,,VOBARRAY
ARRYQ2: VREADTABLE,,[PRDTBL]
VNIL,,VOBARRAY
ARRYQ3: 0,,2*LRCT ;MAX INDEX+1,,LENGTH OF DATA
OBTSIZ+1+200,,OBTSIZ+1+200 ;FOOEY - GLS
ARRYQ4: -1,,3 ;STANDARD GC AOBJN POINTER:
-<OBTSIZ+1>/2,,3 ; -<LENGTH IN WDS>,,<REL POS OF DATA>
ARRYQ5: RDTFIX ;FIXUP ROUTINE FOR AFTER BLT
OBAFIX
ARRY1D: SKIPA AR2A,A
ARRY1F: HRRZ AR2A,(AR2A) ;AR2A HAS SAR OF ARRAY TO COPY FROM
MOVNI AR1,2(T) ;AR1 HAS NUMBER OF DIMENSIONS
PUSH FXP,INHIBIT ;HALF A LOCKI
HRRZ R,ARRYQ3(F) ;R HAS LENGTH OF ARRAY DATA
HLRZ D,ARRYQ3(F) ;D HAS 1+LARGEST LEGAL INDEX
PUSH FXP,D
JRST ARRY2F
ARRY2: CAML T,XC-2 ;REGULAR ARRAY
JRST ARRY0G
PUSH FXP,INHIBIT ;HALF A LOCKI
MOVEI R,1 ;R ACCUMULATES SIZE OF DATA
HRREI D,2(T) ;-<# OF DIMENSIONS>
MOVNI AR1,2(T) ;AR1 GETS NUMBER OF DIMENSIONS
ARRY2A: POP P,A
ARRY2B: JSP T,FXNV1
TLNN TT,-1
JUMPG TT,ARRY2C
WTA [ILLEGAL DIMENSION - *ARRAY!]
JRST ARRY2B
ARRY2C: PUSH FXP,TT
IMULI R,(TT) ;PRODUCT OF ALL DIMENSIONS
AOJL D,ARRY2A
MOVEI D,(R) ;R HAS SIZE OF DATA, AR2A HAS NIL,
SETZ AR2A, ; D HAS 1+LARGEST LEGAL INDEX
ARRY2F: SETOM INHIBIT ;OTHER HALF OF LOCKI
HRLM AR1,TOTSPC ;SAVE NUMBER OF DIMENSIONS
MOVEI T,(AR1) ;T ACCUMULATES SIZE OF HEADER
MOVEM D,LLIP1 ;SAVE 1+LARGEST LEGAL INDEX
MOVSI D,AS<SX>
TDNN D,ARYTP1(F) ;S-EXP OR FULLWORD ARRAY?
AOJA T,ARRY2H ;FULLWORD NEEDS EXTRA WORD IN HEADER
ADDI R,1 ;S-EXP PACKS TWO ENTRIES PER WORD
LSH R,-1
ARRY2H: MOVNM R,BPPNR ;-<SIZE OF ARRAY DATA IN WORDS>
ADDI T,2 ;TWO WDS IN HEADER FOR JSP AND SAR
HRLM T,BPPNR ;SAVE SIZE OF HEADER
ADDI R,1(T) ;ONE WORD FOR GC AOBJN POINTER
HRRM R,TOTSPC ;SAVE TOTAL SIZE OF ARRAY IN WORDS
MOVEM AR2A,(P) ;CLOBBER 2ND ARG WITH SAR OF ARRAY TO COPY
PUSH FXP,F ;SAVE ARRAY TYPE
ARRY3: SKIPN A,-1(P) ;ARRAY OF NIL GIVES A SAR
JRST ARRY3A ;DON'T DO SARGET FOR NIL
PUSHJ P,SARGET
JUMPN A,ARRY6 ;ALREADY HAS A SAR
ARRY3A: JSP T,SACONS
MOVEI B,(A)
MOVEI C,QARRAY
SKIPE A,-1(P)
PUSHJ P,PUTPROP ;AND PUTPROP IT UNLESS ATOM IS NIL
JUMPN A,ARRY6
MOVEM B,-1(P) ;WE WANT TO RETURN THE SAR, NOT NIL!
MOVEI A,(B)
ARRY6: MOVEM A,ADDSAR ;ADDRESS OF THE SAR
MOVEI B,ADEAD
MOVEM B,ASAR(A) ;THIS SAYS THE OLD ARRAY, IF ANY, IS DEAD
MOVE B,GCMKL
PUSHJ P,MEMQ
JUMPE A,ARRY6Q
MOVEI B,DEDSAR
HRLM B,(A)
ARRY6Q: HRRZ TT,TOTSPC
MOVEM TT,GAMNT
MOVEI AR2A,GCMKL ;RUNNING BACKUP POINTER FOR GCMKL
MOVEI C,0 ;TAIL OF GAMKL FOR WINNING DEAD BLOCK
MOVEI F,-1 ;SIZE OF SMLST DEAD BLOCK NOT SMLR THAN REQUESTED
SKIPA D,BPSH ;RUNNING LOCATION OF BLOCK BEGINNINGS
ARRY6A: MOVE AR2A,AR1
HRRZ B,(AR2A)
JUMPE B,ARRY7 ;ALL DONE WITH GCMKL
HRRZ AR1,(B)
HLRZ A,(AR1)
MOVE TT,(A)
SUB D,TT
HLRZ A,(B)
HLRZ A,ASAR(A) ;ALIVEP
JUMPN A,ARRY6A
CAMGE TT,F
CAMGE TT,GAMNT
JRST ARRY6A
MOVE F,TT
MOVE C,AR2A
MOVE R,D
JRST ARRY6A
ARRY7: JUMPN C,ARRY7A ;FOUND DEAD BLOCK BIG ENOUGH
HRRZ TT,TOTSPC ;ELSE MUST GRAB NEW BLOCK OF REQUISITE SIZE
PUSHJ P,AGTSPC
JUMPE A,ARRY8
SUB TT,TOTSPC
HRRZM TT,INSP
HRRZ TT,TOTSPC ;WILL MAKE AN ENTRY
JSP T,FIX1A ;ON GCMKL.
PUSHJ P,NCONS
MOVE B,ADDSAR
PUSHJ P,XCONS
MOVEI B,(A)
MOVEI A,GCMKL
PUSHJ P,.NCNC1
MOVE TT,INSP
JSP T,FIX1A
MOVEM A,VBPEND
JRST ARRY5
ARRY7A: HRRZ AR1,(C) ;C POINTS TO GCMKL TAIL WITH DEAD BLK TO BE USED
SUB F,GAMNT ;F HAD SIZE OF USEABLE DEAD BLK
JUMPN F,ARRY7B
MOVE B,ADDSAR ;DEAD BLOCK IS EXACTLY SIZE NEEDED
HRLM B,(AR1) ; SIMPLY SPLICE SAR INTO GCMKL AND XIT
JRST ARRY4
ARRY7B: ADD R,F ;SLICE UP DEAD BLOCK INTO ARRAY IN HIGHER
MOVEI A,DBM ; PART AND NEW DEAD BLK IN LOWER
HRLM A,(AR1)
MOVE TT,F
JSP T,FIX1A
HRRZ AR1,(AR1) ;INSTALL NEW DEAD BLOCK MARKER,
MOVEI AR2A,(A) ; AND NEW DEAD BLOCK SIZE
HRRZ TT,TOTSPC
JSP T,FIX1A
HRRZ B,(C)
PUSHJ P,CONS
MOVE B,ADDSAR
PUSHJ P,XCONS
HRLM AR2A,(AR1)
XCTPRO
HRRM A,(C) ;PROTECTED, JUST TO BE SAFE
NOPRO
ARRY4: HRRZM R,INSP ;R NOW HOLDS BEGINNING OF BLOCK FOR NEW ARRAY
ARRY5: POP FXP,F ;INDEX INTO ARYTP1
HRRZ R,INSP ;R HELPS PUSH OUT ARRAY HEADER
CAIGE F,NPARTP ;MAKE UP AOBJN POINTER FOR GC
SKIPA C,ARRYQ4(F)
MOVS C,BPPNR
ADDI C,2(R) ;ALLOW FOR SIZE OF HEADER, ETC.
PUSH R,C
MOVEI T,DIMFTB ;NOW FOR THE JSP
SKIPN TT,ARYIN1(F) ;OOPS! DO WE NEED EXTRA INSTRUCTION?
10% TRCA T,DIMSTB#DIMFTB ;NO, MUST BE S-EXP ARRAY
10$ SKIPA T,[DIMSTB] ;RELOCATION LOSSAGE
PUSH R,TT ;YES, PUSH IT OUT FIRST
HLRZ D,TOTSPC ;NUMBER OF DIMENSIONS
ADDI T,-1(D)
PUSH R,(T) ;PUSH OUT JSP TO CORRECT PLACE
PUSH R,ADDSAR ;PUSH OUT ADDRESS OF SAR
ARRY5D: POP FXP,T ;PUSH OUT ARRAY DIMENSIONS, IN ORDER
PUSH R,T
SOJG D,ARRY5D
SETZM 1(R) ;ZERO FIRST WORD OF DATA
MOVSI A,1(R) ;MAKE UP BLT POINTER
HRRI A,2(R)
MOVN C,BPPNR
ADDI C,(R) ;C HAS LIMIT FOR BLT
POP P,AR1 ;DO WE WANT TO COPY ANOTHER ARRAY?
JUMPE AR1,ARRY5F ;NO - ZERO OUT ARRAY
HRL A,TTSAR(AR1) ;YES - REARRANGE BLT POINTER
SOJA A,ARRY5G
ARRY5F: TLZ C,-1 ;FOR ONE-WORD ARRAY, DON'T DO BLT!
CAIE C,-1(A)
ARRY5G: BLT A,(C)
MOVE AR2A,ADDSAR ;PUT CORRECT STUFF INTO SAR ITSELF
MOVE TT,INSP
ADDI TT,2
HLL TT,ARYTP1(F)
MOVEM TT,ASAR(AR2A)
ADDI R,1
HRRM R,TTSAR(AR2A)
HLRZ D,TOTSPC
DPB D,[TTSDIM,,TTSAR(AR2A)]
CAIGE F,NPARTP
PUSHJ P,@ARRYQ5(F) ;PECULIAR ARRAYS NEED FIXING UP
MOVE B,ADDSAR ;RETURN SAR IN B
POP P,A ;RETURN ARG 1 IN A
UNLKPOPJ
ARRY8: SUB P,R70+1
HLRZ TT,TOTSPC
MOVNI TT,1(TT)
HRLI TT,-1(TT)
ADD FXP,TT
HRRZ TT,TOTSPC
JSP T,FXCONS
PUSHJ P,NCONS
MOVEI B,Q%%ARRAY
PUSHJ P,NCONS
UNLOCKI
FAC [NO CORE - *ARRAY!]
SUBTTL AREGET ROUTINE
AREGET: PUSH P,A ;GET AN ARRAY SAR (AND INSIST ON ONE!)
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,SA
JRST AREGT0 ;A SAR ITSELF IS ACCEPTABLE
AREGT2: PUSHJ P,ARGET ;SO IS A SYMBOL WITH AN ARRAY PROPERTY
JUMPE A,AREGT1
AREGT0: MOVE TT,ASAR(A) ;A KILLED ARRAY IS AS BAD AS NO ARRAY
CAIE TT,ADEAD
JRST POP1J ;SUCCESS! RETURN THE SAR IN A
AREGT1: POP P,A ;FAILURE! CRAP OUT
WTA [NOT AN ARRAY!]
JRST AREGET
SUBTTL MKDTAR/MKLSAR ROUTINE, AND ARRAYDIMS FUNCTION
MKFLAR: SKIPA T,[QFLONUM]
MKFXAR: MOVEI T,QFIXNUM
JRST MKAR1
MKDTAR: TDZA T,T ;MAKE UP A DATA ARRAY [NO GC PROTECTION FOR ELTS]
MKLSAR: MOVEI T,TRUTH ;MAKE UP A LIST ARRAY [GC PROTECTION]
LSH TT,1 ;FINDS NUMBER OF DATA WORDS DESIRED IN TT
MKAR1: PUSH P,[PX1J] ;A CONTAINS NAME FOR ARRAY
PUSH P,A ;A=NIL => GENSYM A NAME
PUSH P,T ;A=<-1,,> => JUST RETURN THE SAR
PUSH FXP,TT ;LEAVES GENSYMMED NAME OF ARRAY IN A
MOVEI A,(FXP)
PUSH P,A ;LEAVES ADDRESS OF SAR IN B
MOVEI T,0
SKIPN A,-2(P)
PUSHJ P,GENSYM
HRRZM A,-2(P)
MOVNI T,3
JRST %%ARRAY
SPECPRO INTZAX
SACONS: SKIPN FFA ;SAR CONSER
PUSHJ P,AGC
MOVE A,@FFA
XCTPRO
EXCH A,FFA
NOPRO
HRLI T,((TT))
HLLM T,TTSAR(A)
JRST (T)
ADIMS0: MOVEI A,(C)
WTA [BAD ARG - ARRAYDIMS!]
ADIMS: MOVEI C,(A)
PUSHJ P,SARGET ;SUBR 1 - ARG MUST BE ARRAY
JUMPE A,ADIMS0
LOCKTOPOPJ
HRRZ T,ASAR(A) ;OKAY FOR ARRAY TO BE DEAD
CAIN T,ADEAD ; - GIVE OUT NIL
JRST FALSE
MOVEI C,(A)
MOVE T,ASAR(C)
JFFO T,.+1
HRRZ F,ARYTYP(TT) ;F HAS SYMBOL FOR ARRAY TYPE
LDB D,[TTSDIM,,TTSAR(C)]
MOVNI D,(D) ;D HAS -<# OF DIMS>
MOVNI R,1
TDZA B,B
ADIMS1: MOVEI B,(A) ;CONS UP LIST OF DIMENSIONS
MOVEI TT,(R)
MOVE TT,@TTSAR(C)
JSP T,FXCONS
PUSHJ P,CONS
CAME R,D
SOJA R,ADIMS1
MOVEI B,(F) ;CONS TYPE ON FRONT OF LIST
JRST XCONS
IFN USELESS*<1-QIO>,[
SUBTTL DUMPARRAYS FUNCTION
DUMPARRAYS:
10$ PUSH P,R70
PUSH P,B
PUSH P,A
MOVE A,B
IFN ITS,[
MOVEI T,7
PUSHJ P,UINITA
TSOPEN DSIC,UTIN
]
IFN D10,[
PUSHJ P,LDOPN ;USE COMMON OPEN SUBR
JRST NODEV ;DEVICE NOT AVAILABLE
MOVEM A,-2(P) ;SAVE ARRAY ADDR ON PDL
ENTER DSIC,T ;ENTER FILE
JRST NOENT ;COMMON ENTER ERROR TYPOUT
]
UNLOCKI
MOVE B,(P)
JRST DMPA0A
DMPA0: HRRZ B,@(P)
MOVEM B,(P)
DMPA0A: HLRZ A,(B)
JUMPN B,DMPA1
MOVE T,[-1,,CLOSS]
10% .IOT DSIC,T
10% .CLOSE DSIC,
10% JRST S1PAJ
IFN D10,[
PUSHJ P,D10AOJ ;PUMP OUT DATA
OUT DSIC,D10ARD ;OUTPUT LAST BUFFERFUL
JRST .+2
JRST D10AR4
RELEASE DSIC, ;DISOWN THE CHANNEL
MOVE A,-1(P)
SUB P,R70+3 ;ADJUST PDL
POPJ P,
] ;END OF IFN D10
DMPAER: POP P,A
WTA [NOT DATA ARRAY - DUMPARRAY!]
DMPA1: PUSH P,A
PUSHJ P,PNGET
MOVE T,[-1,,TT]
MOVEI TT,0
MOVE B,A
JUMPE B,DMPA3
HRRZ B,(B)
AOJA TT,.-2
DMPA3: MOVN D,TT ;TT HOLDS NUMBER OF WORDS IN PNAME
HRL TT,D ;CONVERTED INTO -N,,N
DMPA3A:
10% .IOT DSIC,T ;AOBJN PTR FOLLOWED BY WORDS OF PNAME
10$ PUSHJ P,D10AOJ
JUMPE A,DMPA3B ;END WHEN PNAME LIST EXHAUSTED
HLRO T,(A) ;-1,,ONE-WORD-OF-PNAME
HRRZ A,(A)
JRST DMPA3A
DMPA3B: MOVE A,(P)
PUSHJ P,AREGET
MOVE TT,ASAR(A)
TLNE TT,AS<RDT+OBA+GCP>
JRST DMPAER ;CANT RE-LOAD AN S-EXP ARRAY
LOCKI
SUB P,R70+1
MOVE B,ASAR(A)
HLLZ TT,-1(B)
TLNE B,AS<FX>
HRRI TT,1
TLNE B,AS<FL>
HRRI TT,2
MOVE T,[-1,,TT]
10% .IOT DSIC,T ;AOBJN PTR FROM ARRAY
10$ PUSHJ P,D10AOJ ;DUMP AOBJN WORD ITSELF
MOVE T,-1(B)
10% .IOT DSIC,T ;WHOLE ARRAY
10$ PUSHJ P,D10AOJ ;DUMP DATA IT REFERS TO
UNLOCKI
JRST DMPA0
IFN D10,[
;;; EXPECT AOBJN WORD IN T FOR TRANSFER
D10AOJ: MOVE T+3,D10PTR
D10AJ1: MOVE T+2,(T) ;GET THE WORD FROM LISP
AOBJN T+3,D10AJ3 ;ROOM IN DEC'S BUFFER?
OUT DSIC,D10ARD ;NO, DUMP BUFFER..
JRST D10AJ2 ;RESET POINTER
D10AR4: RELEASE DSIC, ;CLOSE AND DISOWN
LERR [SIXBIT /OUTPUT FAILURE - DUMPARRAY!/]
D10AJ2: MOVE T+3,D10ARD ;RESET POINTER
D10AJ3: MOVEM T+2,(T+3) ;DROP INTO BUFFER
AOBJN T,D10AJ1 ;LOOP FOR MORE
MOVEM T+3,D10PTR ;SAVE POINTER FOR LATER
POPJ P, ;BACK TO CALLER
LDOPN: PUSHJ P,UINITA
MOVEI TT,UTBSIZ ;LOAD LENGTH OF BUFFER TO GET
JRST IOO
] ;END OF IFN D10
CLOSS: 014060301406 ;ASCII FOR ↑C↑C↑C↑C↑C
SUBTTL LOADARRAYS FUNCTION
LDAERR: UNLOCK
JSP R,RSTR2
WTA [LOSING DATA FILE - LOADARRAY!]
LOADARRAYS:
10$ PUSH P,R70
PUSH P,A
10% MOVEI T,6
10% PUSHJ P,UINITA
10% TSOPEN DSIC,UTIN
IFN D10,[
PUSHJ P,LDOPN
JRST NODEV ;USE COMMON COMPLAINER
MOVEM A,-1(P) ;SAVE ARRAY ON SAVED PDL SLOT
LOOKUP DSIC,T ;TRY TO FIND OUR FILE
LERR [SIXBIT /LOOKUP ERROR - LOADARRAY!/]
SETZM D10PTR ;ENABLE FOR INITIAL READ
] ;END OF IFN D10
UNLOCKI
PUSH P,R70 ;LIST OF ARRAYS
LDAR1: JSP R,LDAR0 ;GET AOBJN PTR FOR PNAME OF DUMPED ARRAY
MOVE R,D ;D WILL BE -N,,N FOR N WORDS OF PNAME
CAMGE D,[-LPNBUF,,]
JRST LDAR5
HRRI R,PNBUF ;SMALL ENOUGH PNAME TO FIT IN PNBUF
10% .IOT DSIC,R
10$ PUSH FXP,T
10$ MOVE T,R
10$ PUSHJ P,D10GET
10$ POP FXP,T
MOVEI C,PNBUF-1(D)
SETOM LPNF
LDAR4: PUSHJ P,RINTERN ;GET DUMPED NAME OF ARRAY
JSP R,LDAR0
MOVEI F,(D)
CAILE F,2
SETZ F,
HLRES D
MOVMS D
CAILE D,300000
JRST LDAERR
MOVE B,A
MOVE TT,D
ASH TT,1
JSP T,FIX1A
PUSHJ P,ACONS ;LIKE NCONS, BUT SAVES B
PUSHJ P,XCONS
PUSH P,A
MOVE TT,D
MOVEI A,NIL
LOCKI
PUSHJ P,@LDAR9Q(F)
MOVE TT,ASAR(B) ;SAR ADDRESS IN B
MOVE T,-1(TT) ;AOBJN PTR
10% .IOT DSIC,T
10$ PUSHJ P,D10GET
UNLOCKI
POP P,B
PUSHJ P,CONS ;(NEWNAME DUMPEDNAME SIZE)
MOVE B,(P)
PUSHJ P,CONS
MOVEM A,(P)
JRST LDAR1
LDAR9Q: MKDTAR
MKFXAR
MKFLAR
IFN D10,[
;;; AOBJN WORD IN T, FETCH FROM BUFFER
D10GET: PUSH FXP,TT ;MUST SAVE ALL
PUSH FXP,D
LOCKI ;NO INTERRUPTIONS
D10AJ7: AOSL D,D10PTR ;CHECK FOR MORE DATA
JRST D10AJ8
D10AJ5: MOVE TT,@LDBSAR .SEE ASAR ;GET ARRAY ADDR
MOVE TT,-1(TT)
ADDI D,UTBSIZ(TT) ;ADJUST WITH COUNTER
MOVE D,(D) ;GET THE WORD
MOVEM D,(T) ;STORE IT
AOBJN T,D10AJ7
UNLOCKI
JRST RSTX2 ;RESTORE TT D AND POPJ
D10AJ8: MOVNI D,200
MOVEM D,D10PTR
IN DSIC,D10ARD
JRST D10AJ5 ;WE GOT IT
RELEASE DSIC, ;WE DIDNT......
LERR [SIXBIT /OUT OF SYNC - LOADARRAY!/]
] ;END OF IFN D10
LDAR5:
10% MOVE F,[-1,,TT] ;PNAME IS TOO LONGTO FIT IN PNBUF
10% .IOT DSIC,F
10$ PUSH FXP,T
10$ MOVE T,[-1,,F] ;LET'S USE F INSTEAD
10$ PUSHJ P,D10GET
10$ MOVE TT,F ;PUT IT WHERE IT WANTS IT
10$ POP FXP,T
JSP T,FIX1A
PUSH P,A
AOBJN R,LDAR5
HLRE T,D
JSP R,LIST1
SETZM LPNF
JRST LDAR4
LDAR0:
IFE D10,[
MOVE D,CLOSS
MOVE T,[-1,,D]
.IOT DSIC,T
CAME D,CLOSS
JRST (R)
.CLOSE DSIC, ;ALL DONE
] ;END OF IFE D10
IFN D10,[
PUSH FXP,R
MOVE T,[-1,,R]
PUSHJ P,D10GET
MOVE D,R
CAME R,CLOSS
POPJ FXP,
RELEASE DSIC, ;NORMAL CLOSURE
POP FXP,R
] ;END OF IFN D10
POP P,A
10% SUB P,R70+1
10$ SUB P,R70+2
JRST NREVERSE
] ;END OF IFN USELESS*<1-QIO>
IFN D10,[
IOO: MOVEI A,400000 ;IMAGEOUT OPEN
PUSHJ P,MKFXAR ;MAKE AN ARRAY
HRRZM B,LDBSAR ;SAVE BASE
MOVE T,(B)
MOVE T,-1(T)
SUBI T,1
MOVEM T,D10ARD
MOVEM T,D10PTR
SETZ T+2,
MOVEI T,16
LDOPN1: MOVE T+1,UTIN
OPEN DSIC,T
POPJ P, ;THIS IS AN ERROR RETURN
MOVE T,UFN1 ;MOVE FILENAME
HLLZ T+1,UFN2 ;MOVE EXTENSION
SETZ T+2,
MOVE T+3,USN ;MOVE [P,PN] TO LOOKUP/ENTER BLOCK
JRST POPJ1 ;SKIP RETURN FOR SUCCESS.
] ;END OF IFN D10
SUBTTL BLTARRAY FUNCTION AND FRIENDS
BLTARRAY: EXCH A,B ;GRUMBLE! CALLED BY FILLARRAY
PUSH P,B
PUSHJ FXP,SAV5M3
PUSHJ P,AREGET
MOVEI AR1,(A)
HRRZ A,-2(P)
BLTAR1: PUSHJ P,AREGET
MOVEI AR2A,(A)
IFN QIO,[
MOVE T,ASAR(AR1)
MOVE TT,ASAR(AR2A)
IFN JOBQIO,[
TLNE T,AS<JOB>
JRST BLTALS
TLNE T,AS<JOB>
JRST BLTALZ
] ;END OF IFN JOBQIO
TLNE T,AS<FIL>
JRST BLTI1
TLNE TT,AS<FIL>
JRST BLTO1
] ;END OF IFN QIO
LOCKI
PUSHJ P,.REA3
JRST BLTALZ ;ARRAY TYPES DON'T MATCH - LOSE LOSE
BLTXIT: PUSHJ FXP,RST5M3
UNLOCKI
JRST POPAJ
BLTALZ: UNLOCKI
MOVEI A,(AR2A)
WTA [BAD TARGET ARRAY TYPE - BLTARRAY!]
MOVEI AR2A,(A)
JRST BLTAR1
BLTALS: UNLOCKI
MOVEI A,(AR1)
WTA [BAD SOURCE ARRAY TYPE - BLTARRAY!]
MOVEI AR1,(A)
JRST BLTAR1
;;; SMASH ARRAY WHOSE SAR IS IN AR1 INTO ARRAY WHOSE SAR IS IN AR2A
;;; SKIPS ON SUCCESS - FAILS WHEN ARRAY TYPES DON'T MATCH
.REA3: HLRZ TT,ASAR(AR1)
HLRZ D,ASAR(AR2A)
XORI TT,(D)
ANDCMI TT,AS<GCP>
JUMPN TT,CPOPJ
AOS (P)
MOVEI A,(AR1)
JSP T,ARYSIZ
MOVE R,F
MOVEI A,(AR2A)
JSP T,ARYSIZ
TRNN D,AS<SX>
JRST .REA3A
ADDI R,1
ADDI F,1
LSH R,-1
LSH F,-1
.REA3A: CAML F,R
MOVE F,R
ADD F,TTSAR(AR2A)
HRRZ R,TTSAR(AR2A)
HRL R,TTSAR(AR1)
BLT R,-1(F)
TRNN D,AS<RDT+OBA>
C.REA2: POPJ P,.REA2
TRNN D,AS<RDT>
JRST OBAFX1
JRST RDTFIX
ARYSIZ: HLL T,ASAR(A) ;TAKES SAR IN A, RETURNS PRODUCT OF
TLNE T,AS<RDT+OBA> ; ALL DIMENSIONS IN F; SAVES D,R
JRST ARYSZ5
LDB TT,[TTSDIM,,TTSAR(A)]
MOVNI TT,(TT)
MOVE F,@TTSAR(A)
ARYSZ3: AOJE TT,(T)
IMUL F,@TTSAR(A)
JRST ARYSZ3
ARYSZ5: MOVEI F,OBTSIZ+1+200
TLNN T,AS<OBA>
MOVEI F,LRCT
JRST (T)
OBAFIX: JUMPE AR1,CPOPJ ;FIX UP OBARRAY AFTER A BLTARRAY, ETC.
OBAFX1: MOVE T,TTSAR(AR2A) ; BY COPYING ALL THE BUCKETS
HRLI T,442200 ;USER INTERRUPTS SHOULD BE SHUT OFF
MOVEI D,OBTSIZ
OBAFX3: ILDB A,T
SETZ B,
PUSHJ P,.APPEND ;USE *APPEND TO COPY LISTS
DPB A,T
SOJG D,OBAFX3
POPJ P,
RDTFIX: SKIPA R,PROLIS ;FIX UP A READTABLE AFTER A BLTARRAY, ETC.
RDTFX2: HRRZ R,(R) ; BY DUPLICATING ALL PROLIS ENTRIES
JUMPE R,CPOPJ ; FOR MACRO CHAR FUNCTIONS
HLRZ D,(R)
HRRZ TT,(D)
HLRZ T,(TT)
CAIE T,(AR1)
JRST RDTFX2
HRRZ B,(TT)
MOVEI A,(AR2A)
PUSHJ P,CONS
HLRZ B,(D)
PUSHJ P,XCONS
MOVE B,PROLIS
PUSHJ P,CONS
MOVEM A,PROLIS
JRST RDTFX2
IFN QIO,[
;FILL OUTPUT FILE IN AR2A FROM ARRAY IN AR1.
BLTO1: TLNN T,AS<FIL+RDT+OBA> ;FILES, READTABLES, OBARRAYS BAD
TLNE T,AS<GCP> ;GC-ABLE ARRAY NOT VALID SOURCE
JRST BLTALS
EXCH AR1,AR2A
PUSHJ P,XOFLOK
SKIPL F.MODE(TT) .SEE FBT.CM
JRST BLTO2
UNLOCKI ;INSIST ON BLOCK MODE
EXCH AR1,AR2A
JRST BLTALZ
BLTO2: PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF WORDS
MOVNI T,(F)
MOVSI T,(T)
HRR T,TTSAR(AR2A)
MOVE TT,TTSAR(AR1)
JUMPL T,BLTO3
TLC T,400000 ;GRUMBLE - IOT POINTERS
.CALL IOTTTT ; CAN INDICATE AT MOST
.VALUE ; 400000 WORDS
HRLI T,400000
BLTO3: .CALL IOTTTT ;OUTPUT CRUFT FROM ARRAY
.VALUE
PUSHJ P,FORCE5 ;UPDATE PARAMETERS
JRST BLTXIT
;FILL ARRAY IN AR2A FROM FILE IN AR1.
BLTI1: TLNN TT,AS<FIL+RDT+OBA> ;FILES, READTABLES, OBARRAYS BAD
TLNE TT,AS<GCP> ;GC-ABLE ARRAYS NOT VALID
JRST BLTALZ
PUSHJ P,XIFLOK
SKIPL F.MODE(TT)
JRST BLTI2
UNLOCKI ;INSIST ON BLOCK MODE FILE
JRST BLTALS
BLTI2: MOVEI A,(AR2A)
JSP T,ARYSIZ ;DETERMINE NUMBER OF DATA WORDS
MOVE TT,TTSAR(AR1)
HLRE T,XB.AOB(TT)
JUMPGE T,BLTI4
MOVNS D,T ;FIRST TRY TO USE ANY
CAILE D,(F) ; WORDS ALREADY IN BUFFER
MOVEI D,(F) ;NUMBER OF WORDS TO BLT
HRRZ R,TTSAR(AR2A) ;CONSTRUCT BLT POINTER
HRL R,XB.AOB(TT)
ADDI D,-1(R)
BLT R,(D) ;*** BLT! ***
CAIGE T,(F)
JRST BLTI4
HRLI F,(F) ;WE GOT ALL WE NEEDED FROM
ADDM F,XB.AOB(TT) ; THE BUFFER, SO UPDATE AOBJN
JRST BLTXIT ; POINTER AND EXIT
BLTI4: SUBI F,(T) ;STILL NEED MORE WORDS FROM FILE
ADD T,TTSAR(AR2A)
MOVNI D,(F)
HRLI T,(D)
ADDM F,F.FPOS(TT)
JUMPL T,BLTI6
TLC T,400000
.CALL IOTTTT
.VALUE
JUMPGE T,BLTI5
TLC T,400000
JRST BLTI7
BLTI5: HRLI T,400000
BLTI6: .CALL IOTTTT ;IOT WORDS INTO ARRAY
.VALUE
SETZM XB.AOB(TT) ;FORCE FRESH INPUT FOR NEXT TIME
JUMPGE T,BLTXIT ;WIN IF WE GOT ALL WORDS
BLTI7: HLRO F,T
ADDM F,F.FPOS(TT) ;ADJUST FPOS FOR HOW MANY WORDS
HRRZ C,FI.EOF(TT)
UNLOCKI
JUMPE C,BLTI8
MOVEI A,(AR1)
JCALLF 1,(C) ;CALL USER EOF FUNCTION
BLTI8: MOVEI A,(AR2A)
PUSHJ P,NCONS
MOVEI B,(AR1)
PUSHJ P,XCONS
MOVEI B,QFILLARRAY
PUSHJ P,XCONS
IOL [EOF - FILLARRAY!] ;ELSE GIVE IO-LOSSAGE ERROR
] ;END OF IFN QIO
SUBTTL *REARRAY FUNCTION
.REARRAY: ;THIS CODE COULD STAND MUCH IMPROVEMENT
JSP TT,LWNACK
LA1234567,,Q.REARRAY
AOJE T,.REA1
MOVEI D,(P)
ADDI D,(T)
HRLI D,(T)
HRRZ A,(D)
SUBI T,1
PUSH FXP,INHIBIT ;HALF A LOCKI
PUSH FXP,T
PUSHJ P,AREGET
SETOM INHIBIT ;OTHER HALF OF LOCKI
PUSH P,A
HLRZ T,ASAR(A)
HRRZ A,1(D)
.REA4: MOVSI F,-LARYTP
.REA5: HRRZ B,ARYTP1(F)
CAIN B,(A)
JRST .REA7
AOBJN F,.REA5
.REA6: POP FXP,T
UNLOCKI
WTA [BAD ARRAY TYPE - *REARRAY!]
MOVEM A,1(D)
LOCKI
PUSH FXP,T
JRST .REA4
.REA7: HLRZ TT,ARYTP1(F)
XORI TT,(T)
ANDCMI TT,AS<GCP>
JUMPN TT,.REA6
.REA7A: PUSH P,C.REA2
PUSH P,[QUBAR]
PUSH P,1(D)
AOBJN D,.-1
MOVE T,(FXP)
JRST %%ARRAY
.REA2: HRRZ AR1,(P)
MOVEI AR2A,UB.AC
PUSHJ P,.REA3
JRST .REALOSE
MOVE A,(P)
MOVEI B,ADEAD
EXCH B,UB.AC+ASAR
MOVEM B,ASAR(A) ;STORE NEW CONTENTS OF ASAR
TLNE B,AS<FX+FL>
ADDI B,1
MOVEM A,1(B) ;INSTALL CORRECT SAR IN ARRAY
MOVE B,UB.AC+TTSAR
HLLOS UB.AC+TTSAR
MOVEM B,TTSAR(A) ;STORE NEW CONTENTS OF TTSAR
MOVE B,GCMKL
PUSHJ P,MEMQ
JUMPE A,.REALOSE
MOVEI B,DEDSAR
HRLM B,(A)
MOVE B,GCMKL
MOVEI A,UB.AC
PUSHJ P,MEMQ
JUMPE A,.REALOSE
MOVE B,(P)
HRLM B,(A)
POP FXP,T
UNLOCKI
HRLI T,-1(T)
ADD P,T
JRST POPAJ
.REALOSE: SUB P,R70+1
POP FXP,T
UNLOCKI
JSP R,LIST1
PUSHJ P,NCONS
MOVEI B,Q.REARRAY
PUSHJ P,XCONS
FAC [*REARRAY LOST!]
GETSP: JSP TT,LWNACK
LA12,,QGETSP
POP P,A
MOVEI D,GETSP1
HRL D,VPURE
AOJE T,GETSP0
HRLI D,(A)
POP P,A
GETSP0: JSP T,FXNV1 ;RETURNS BPEND-BPORG IF SPACE IS AVAILABLE
TLCE D,-1
TLZ D,-1
LOCKTOPOPJ
PUSH P,D
AGTSPC: MOVEM TT,GAMNT
ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT)
SUB TT,@VBPEND
JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE.
MOVE A,VBPEND ;ALREADY OK
MOVE TT,(A)
POPJ P,
GETSP1: JUMPE TT,FALSE
SUB TT,@VBPORG
JRST FIX1
.REA1: MOVE A,(P) ;REMOVES ARRAY BY PUTTING ADDRESS OF
PUSHJ P,SARGET ; ERROR ROUTINE IN SAR, ETC.
JUMPE A,POP1J
MOVEI B,ADEAD
XCTPRO
MOVEM B,ASAR(A)
MOVE B,[TTDEAD]
MOVSI T,TTS<CN>
TDNE T,TTSAR(A)
IOR B,T
MOVEM B,TTSAR(A)
NOPRO
JRST POPAJ
SUBTTL MULTI-DIMENSIONAL ARRAY ACCESS ROUTINES
SFXPRO
AYNV1: HRRZ R,(TT)
MOVEM R,LISAR
AOJA TT,AYNV0
AYNV5: SKIPA A,AR2A
AYNV4: MOVEI A,(AR1)
JRST AYNV0
AYNV3: SKIPA A,C
AYNV2: MOVEI A,(B) ;LEFT HALF OF B MAY BE NON-ZERO
AYNV0: MOVEI R,(A)
LSH R,-SEGLOG
MOVE R,ST(R)
TLNN R,FX
JRST AYNVER
SKIPL R,(A)
CAML R,(TT)
JRST AYNVBD
AOJA TT,(T)
AYNVBD: SKIPA D,[[SIXBIT \ARRAY SUBSCRIPT EXCEEDS BOUNDS!\]]
AYNVER: MOVEI D,[SIXBIT \NON-FIXNUM ARRAY SUBSCRIPT!\]
PUSH P,D
MOVEI R,(TT)
AYNVE1: HLRZ D,-1(R)
CAIE D,(JSP TT,)
SOJA R,AYNVE1
HRRZ D,(R)
SUB TT,ASAR(D)
EXCH D,(P)
XCT AYNVSFX
POP P,D
ADD TT,ASAR(D)
JRST AYNV0
2DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMS1: ADDI R,(F)
JRST ARYGET
2DIMF: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMF1: ADDI R,(F)
JRST ANYGET
3DIMF: TLO B,-1
3DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
3DIMX: TLZE B,-1
JRST 2DIMF1
JRST 2DIMS1
4DIMF: TLO B,-1
4DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV4
JRST 3DIMX
5DIMF: TLO B,-1
5DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV4
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV5
JRST 3DIMX
NOPRO
SUBTTL FILLARRAY AND LISTARRAY
FILLARRAY: SKOTT B,LS
JRST BLTARRAY
MOVEI C,(B)
FILLA0: PUSH P,A
PUSHJ P,AREGET ;GET SAR OF ARRAY
HLLZ D,ASAR(A)
SETZ TT,
Q% TLNE D,AS<RDT+OBA> ;CAN'T FILL READTABLE OR OBARRAY
Q$ TLNE D,AS<JOB+FIL+RDT+OBA> ;CAN'T FILL JOB OR FILE OR READTABLE OR OBARRAY
JRST FILLUZ
JSP T,ARYSIZ ;GET SIZE OF ARRAY
TLNE D,AS<FX+FL>
JRST FILLA2
FILLA1: JUMPE C,FILLA4 ;FILL LOOP FOR S-EXP ARRAYS
HLRZ B,(C)
HRLM B,@TTSAR(A)
HRRZ C,(C)
SOJE F,POPAJ
JUMPE C,FILLA5
HLRZ B,(C)
HRRM B,@TTSAR(A)
HRRZ C,(C)
SOJE F,POPAJ
AOJA TT,FILLA1
FILLA2: MOVEI B,(A) ;FILL LOOP FOR FULLWORD ARRAYS
FILLA3: JUMPE C,FILLA6
HLRZ A,(C)
HRRZ C,(C)
MOVEI R,(TT)
TLNN D,AS<FX>
JSP T,FLNV1X
JSP T,FXNV1
EXCH TT,R
MOVEM R,@TTSAR(B)
SOJE F,POPAJ
AOJA TT,FILLA3
FILLA4: HRLM B,@TTSAR(A)
SOJE F,POPAJ
FILLA5: HRRM B,@TTSAR(A)
SOJE F,POPAJ
ADDI F,1
ROT F,-1 ;ROT, NOT LSH; SEE BELOW
JRST FILLA7
Q$ OPNCLR: MOVEI F,LONBFA ;USED BY $OPEN TO CLEAR ARRAY
Q$ SETZB TT,R ;SAR OF FILE ARRAY IS IN A
Q$ MOVEI B,(A)
Q$ PUSH P,A
FILLA6: MOVEM R,@TTSAR(B)
SOJE F,POPAJ
TLO F,400000 ;AVOID HLLZS BELOW
MOVEI A,(B)
FILLA7: LOCKI
ADD TT,TTSAR(A) ;IF LIST RUNS OUT, DUPLICATE INTO
ADDI F,(TT) ; REMAINING ELEMENTS WITH A BLT
HRLI TT,(TT)
ADDI TT,1
BLT TT,(F)
SKIPL F ;FOR AN ODD LENGTH S-EXP ARRAY, ZERO RH OF
HLLZS (F) ; LAST WORD SO GC WON'T MARK IT SPURIOUSLY
POP P,A
UNLKPOPJ
FILLUZ: POP P,A
WTA [CAN'T FILL THIS OBJECT WITH LIST - FILLARRAY!]
JRST FILLA0
LISTARRAY: JSP TT,LWNACK
LA12,,QLISTARRAY
HRLZI D,377777 ;INITIAL SETTING FOR COUNT
AOJE T,LISTA3
POP P,B ;COUNT INITIALIZED TO 2ND ARG
JSP T,FXNV2 ;IF PRESENT
LISTA3: POP P,A
PUSHJ P,AREGET
JSP T,ARYSIZ ;GET SIZE OF ARRAY
JUMPL D,.+3 ;SET COUNT TO SIZE IF 2ND ARG NEGATIVE
CAMGE D,F ;OR IF 2ND ARG BIGGER THAN SIZE
MOVE F,D
MOVEI C,(A)
SETZB A,B
TLNE T,AS<FX+FL>
JRST LISTA5
MOVEI TT,-1(F)
LSHC TT,-1 ;FIGURE OUT IF ODD OR EVEN
JUMPGE D,LISTA2 ; NUMBER OF ITEMS TO LIST
LISTA1: HRRZ B,@TTSAR(C) ;S-EXP ARRAY LISTING LOOP
PUSHJ P,XCONS
LISTA2: HLRZ B,@TTSAR(C)
PUSHJ P,XCONS
SOJGE TT,LISTA1
POPJ P,
LISTA5: SKIPA D,T ;FULLWORD ARRAY LISTING LOOP
LISTA6: MOVEI B,(A)
MOVEI TT,-1(F)
MOVE TT,@TTSAR(C)
TLNN D,AS<FX> ;CONS UP FLONUM OR FIXNUM?
JSP T,FLCONX ;FLONUM CONS WITH SKIP RETURN
JSP T,FXCONS ;FIXNUM CONS
PUSHJ P,CONS
SOJG F,LISTA6
POPJ P,
PGTOP ARA,[ARRAY STUFF]
;;@ END OF ARRAY 48
;;@ FASLOA 89 FASLOAD
PGBOT FSL
SUBTTL HAIRY RELOCATING LOADER (FASLOAD)
;;; BUFFER PARAMETERS
Q% 10% LLDBF==100 ;LENGTH OF LOADER'S BINARY INPUT BUFFER ARRAY
Q% 10$ LLDBF==201
LLDAT==770 ;LENGTH OF LOADER'S ATOMTABLE ARRAY
ILDAT==1000 ;AMOUNT TO INCREMENT ATOMTABLE ARRAY
LLDSTB==400 ;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES)
;;; PDL OFFSETS
IFE QIO,[
LDAGEN==0 ;SAR FOR ATOMTABLE
LDBGEN==-1 ;SAR FOR I/O BUFFER
LDPRLS==-2 ;PURE CLOBBERING LIST
LDDDTP==-3 ;DDT FLAG
] ;END OF IFE QIO,
.ELSE,[
LDAGEN==0 ;SAR FOR ATOMTABLE
LDPRLS==-1 ;PURE CLOBBERING LIST
LDDDTP==-2 ;DDT FLAG
LDBGEN==-3 ;SAR FOR I/O BUFFER
] ;END OF .ELSE,
LDNPDS==4 ;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES
;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING
;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH
;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED
;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE.
;;; THE ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS
;;; FOR NIL; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH
;;; ATOMTABLE ENTRY IS AS FOLLOWS:
;;; 4.9-4.1 IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY
;;; (4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE
;;; CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS
;;; BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777.
;;; NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE
;;; HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO.
;;; 3.4 THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED
;;; FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED
;;; BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS
;;; IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE
;;; IN THE GC PROTECTION ARRAY (SEE GCPRO).
;;; 3.3-3.2 INDICATES THE TYPE OF ATOM: 0 => SYMBOL,
;;; 1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM.
;;; 3.1 THIS BIT IS TURNED ON IF THE ATOM IS EVER
;;; REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED
;;; CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES).
;;; IT INDICATES THAT THE ATOM MUST SOMEHOW BE
;;; PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR.
;;; 2.9-1.1 CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!)
;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL
;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE
;;; RETRIEVED EXTREMELY QUICKLY.
;;; INTERNAL AUTOLOAD ROUTINE
IFE QIO,[
IALB: HRRZ C,(A)
HLRZ A,IRACOM
HRRZ B,@IUNIT
PUSHJ P,CONS
JSP T,SPECBIND
0 A,IUNIT
NW% SAVEFX UFN1 UFN2
MOVEI A,(C) ;INTERNAL AUTOLOAD BREAK IS ESSENTIALLY FASLOAD
PUSHJ P,FASLOAD
NW% RSTRFX UFN2 UFN1
JRST UNBIND
] ;END OF IFE QIO
IFN QIO,[
IALB: HRRZ AR2A,VDEFAULTF
JSP T,SPECBIND
0 AR2A,VDEFAULTF
HRRZ A,(A) ;SUBR 1
MOVEI B,QCOMDEV
PUSHJ P,MERGEF
PUSHJ P,FASLOAD
JRST UNBIND
] ;END OF IFN QIO
FASLOAD: JSP TT,FWNACK
FA01234,,QFASLOAD
SKIPE FASLP
JRST LDALREADY
PUSH P,FLP ;FOR DEBUGGING PURPOSES
PUSH P,FXP .SEE LDEOMM
PUSH P,SP
SA$ SETZM SAILFL ;FLAG FOR SAIL DUMP MODE IO
IFE QIO,[
AOJN T,LDXXX7
HLRZ A,(A)
MOVEI B,QFASLL
PUSHJ P,CONS
LDXXX7:
] ;END OF IFE QIO
IFN QIO,[
PUSHJ P,FIL6BT
MOVSI T,(SIXBIT \*\)
10% MOVE TT,[SIXBIT \FASL\] ;DEFAULT SECOND FILE NAME IS "FASL"
10$ MOVSI TT,(SIXBIT \FAS\) ;DEFAULT FILE NAME EXTENSION IS "FAS"
CAMN T,(FXP)
MOVEM TT,(FXP)
PUSHJ P,DMRGF
PUSHJ P,6BTNML
] ;END OF IFN QIO
MOVEM A,LDFNAM
MOVEI B,TRUTH
JSP T,SPECBIND
0 B,VNORET
Q% 0 B,FASLP
Q$ FASLP
IFE QIO,[
PUSH P,IUNIT
MOVEI T,6 ;OPEN FASL FILE IN BLOCK IMAGE MODE
PUSHJ P,UINITA
10% .OPEN DSIC,UTIN
10% JRST LDOERR
IFN D10,[
MOVEI T,16
SETZ T+2,
PUSHJ P,LDOPN1 ;USE COMMON OPEN
JRST LDOERR ;USE LOAD ERROR MESSAGE
LOOKUP DSIC,T
JRST LDOERR ;SAME MESSAGE
SETZM D10PTR
] ;END OF IFN D10
SUB P,R70+1 ;SUB OFF OLD IUNIT
UNLOCKI
PUSHJ P,LDFNSET
MOVEM A,LDFNAM
] ;END OF IFE QIO
IFN QIO,[
PUSH P,[LDXXY1]
PUSH P,A
PUSH P,[QFIXNUM]
MOVNI T,2
JRST $OPEN
LDXXY1: MOVEM A,FASLP
PUSH P,A
HRRZM A,LDBSAR
MOVE A,LDFNAM
PUSHJ P,DEFAULTF
SETZM LDTEMP ;CROCK!
] ;END OF IFN QIO
LDDISM: PUSHJ P,LDGDDT ;SET UP DDT FLAG: 0 => NO DDT;
PUSH P,TT ;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS
; ;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY (SEE LDPUT)
SKIPN F,VPURE ;SET UP CALL PURIFY FLAG:
; ;400000,,XXX => NO PURIFY HACKERY
TLOA F,400000 ;200000,,XXX => SUBST XCTS FOR CALLS, PUT CALLS IN SEPARATE PAGES
HRRZ F,VPURCLOBRL ;0,,<PURE LIST> => SUBST PUSHJS AND JRSTS FOR CALLS;
PUSH P,F ; ANY CALLS NOT IMMEDIATELY SMASHABLE
MOVE A,VPURE ; ARE CONSED ONTO THE PURE LIST
PUSHJ P,FIXP ;LEAVES VALUE IN TT IF INDEED FIXNUM
JUMPE A,LDXXX1
MOVSI F,200000
IORM F,(P)
PUSHJ P,LDXHAK ;SET UP XCT HACK PAGES
;FALLS THROUGH
;FALLS IN
LDXXX1:
IFE QIO,[ HRRZ B,FASLP ;FASLP IS T FIRST TIME, ELSE
CAIE B,TRUTH ; SAR OF I/O BUFFER ARRAY
JRST LDXXX8
SETZM LDTEMP
MOVEI TT,LLDBF ;CREATE I/O BUFFER ARRAY
MOVSI A,400000
PUSHJ P,MKFXAR
HRRZM B,LDBSAR ;SAVE ADDRESS OF SAR
MOVEM B,FASLP
LDXXX8: PUSH P,B ;SAVE SAR FOR I/O BUFFER [FROM GC]
] ;END OF IFE QIO
MOVE TT,[-LLDAT+1,,1] ;INIT ATOMTABLE AOBJN INDEX
MOVEM TT,LDAAOB
MOVEI TT,LLDAT ;CREATE ATOMTABLE ARRAY
MOVSI A,400000
PUSHJ P,MKLSAR
PUSH P,A ;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION
HRRZM B,LDASAR ;SAVE ADDRESS OF SAR
PUSHJ P,LDLRSP ;LOCKI, AND SET UP ARRAY POINTERS
SETZ TT, ;ENTRY 0 IN ATOMTABLE IS FOR NIL
SETZM @LDAPTR
MOVEI TT,LDFERR ;INIT ADDRESS FOR PREMATURE EOF
MOVEM TT,LDEOFJ
SKIPE F,LDTEMP ;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER
JRST LDXXX9
JSP T,LDGTW1 ;GET FIRST WORD OF FILE
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\] ;IT BETTER BE THIS VALUE!
JSP D,LDFERR
LDXXX9: JSP T,LDGTWD ;GET VERSION OF LISP FILE WAS ASSEMBLED IN
XOR TT,LDFNM2
MOVEM TT,LDF2DP ;NON-ZERO IFF VERSIONS DIFFERENT
MOVE TT,@VBPORG ;INIT LOAD OFFSET
HRRM TT,LDOFST
MOVE AR1,[000400,,LDBYTS] ;INIT RELOCATION BYTES POINTER
SETZM LDHLOC
JRST LDGTSP
SUBTTL ROUTINE TO SET UP PAGES FOR XCT HACK
;;; TT HAS NUMBER OF PAGES DESIRED.
LDXHAK: SKIPE LDXSIZ ;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY
POPJ P,
SKIPLE TT ;CHECK NUMBER OF PAGES REQUESTED
CAILE TT,10
JRST LDXERR
PUSH FXP,TT
PUSHJ P,PAGEBPORG ;ADJUST BPORG TO BEGINNING OF PAGE
MOVE D,(FXP)
LSH D,PAGLOG ;CONVERT BLOCK COUNT TO WORDS
MOVEM D,LDXSIZ ;SAVE AS SIZE OF XCT AREA
MOVEM D,LDXSM1 ;ALSO NEED THAT VALUE MINUS 1
SOS LDXSM1
MOVE TT,@VBPORG ;CREATE TWO AREAS IN BPS THAT BIG:
HRRZ T,TT ; THE FIRST FOR THE XCTS TO POINT TO,
ADD TT,D ; THE SECOND TO RESTORE THE FIRST FROM
HRL T,TT
MOVEM T,LDXBLT ;SAVE BLT POINTER FOR RESTORING
ADD TT,D
JSP T,FIX1A ;NEW VALUE FOR BPORG
PUSH P,A
LSH D,1 ;NOW TRY TO GET REQUIRED CORE
MOVE TT,D
PUSHJ P,LGTSPC
JUMPE TT,FASLNX
POP P,VBPORG ;GIVE BPORG NEW VALUE
IFN ITS,[
HLLOS NOQUIT ;MUST UPDATE PURTBL ENTRIES
HRRZ T,LDXBLT ; FOR XCT HACK PAGES
ROT T,-PAGLOG-4 ;COMPUTE BYTE POINTER
ADDI T,(T)
ROT T,-1
TLC T,770000
ADD T,[450200,,PURTBL]
MOVE F,[-2,,1] ;WANT TO DO IMPURE PAGES,
SKIPA D,(FXP) ; THEN PURE PAGES
LDXXX3: POP FXP,D ;SECOND TIME THROUGH POP FXP
LDXXX0: TLNN T,730000 ;DEPOSIT BYTE FOR NEXT PAGE
TLZ T,770000
IDPB F,T
SOJG D,LDXXX0 ;COUNT OFF PAGES
AOBJN F,LDXXX3 ;LOOP BACK TO DO PURE PAGES
PUSHJ P,CZECHI
] ;END OF IFN ITS
MOVE T,LDXBLT ;ZERO OUT BOTH AREAS
MOVE TT,@VBPORG
HRL T,T
SETZM (T)
ADDI T,1
BLT T,-1(TT)
JRST TRUE
SUBTTL MAIN FASLOAD LOOP
;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;; AR1 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
;;; F AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY
LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD]
LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD]
LDABS1: AOBJN R,LDBIN ;JUMP IF ROOM LEFT OF WHAT WE GRABBED
LDGTSP: MOVE TT,@VBPEND ;SEE IF ENOUGH ROOM LEFT TO GRAB MORE
SUB TT,@VBPORG
SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY
JUMPGE TT,LDGSP1 ;YES - GO GRAB IT
PUSH FXP,AR1
PUSH FXP,F
MOVEI TT,4*PAGSIZ ;GET MANY BLOCKS OF BPS
LDGS0A: MOVEM TT,GAMNT
PUSHJ P,GTSPC1
JUMPN TT,LDGS0H
MOVE TT,GAMNT
CAIG TT,100
JRST FASLNC
MOVEI TT,100
JRST LDGS0A
LDGS0H: POP FXP,F
POP FXP,AR1
LDGSP1: MOVE R,@VBPORG ;GRAB SOME MORE WORDS
MOVE TT,R
ADDI TT,PAGSIZ ;TRY TO GOBBLE <PAGSIZ>
CAMLE TT,@VBPEND ; WORDS, BUT IN ANY CASE
MOVE TT,@VBPEND ; NO MORE THAN BEYOND BPEND
JSP T,FIX1A
MOVEM A,VBPORG
MOVEI TT,(R)
SUB TT,@VBPORG
HRLI R,(TT) ;INIT AOBJN POINTER IN R
PUSHJ P,LDRSPT ;RESTORE ALL THEM POINTERS, ALREADY
LDBIN: SKIPE INTFLG ;[LOAD BINARY WORD (OR SOME OTHER MESS)]
PUSHJ P,LDTRYI ;GIVE A POOR INTERRUPT A CHANCE IN LIFE
TLNN AR1,770000
JRST LDBIN2 ;OUT OF RELOCATION BYTES - MUST GET MORE
LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE
ILDB T,AR1 ;GET CORRESPONDING RELOCATION BYTE
JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO
LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES
MOVEM TT,LDBYTS
SOJA AR1,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD
LDTTBL: LDABS ; 0 ABSOLUTE
LDREL ; 1 RELOCATABLE
LDSPC ; 2 SPECIAL
LDPRC ; 3 PURIFIABLE CALL
LDQAT ; 4 QUOTED ATOM
LDQLS ; 5 QUOTED LIST
LDGLB ; 6 GLOBALSYM PATCH
LDGET ; 7 GET DDT SYMBOL PATCH
LDAREF ; 10 ARRAY REFERENCE
LDFERR ; 11 UNUSED
LDATM ; 12 ATOMTABLE ENTRY
LDENT ; 13 ENTRY POINT INFO
LDLOC ; 14 LOC TO ANOTHER PLACE
LDPUT ; 15 PUT DDT SYMBOL
LDEVAL ; 16 EVALUATE MUNGEABLE
LDBEND ; 17 END OF BINARY
SUBTTL SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES
LDSPC: MOVE T,TT ;[SPECIAL]
HLR TT,@LDAPTR ;GET ADDRESS OF SPECIAL CELL
TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE?
JRST LDABS ;YES, WIN
TRNE TT,6 ;NO, IS THIS ATOM A NUMBER
JSP D,LDFERR ;YES - LOSE!!!
HRRZ TT,T ;IS THERE AN ATOM THERE AT ALL
HRRZ A,@LDAPTR
SKIPN D,A
JSP D,LDFERR ;NO, LOSE
HLRZ B,(A)
HRRZ A,(B)
CAIE A,SUNBOUND
JRST LDSPC1
PUSH P,D ;NONE THERE - MUST MAKE ONE
MOVEI B,QUNBOUND
JSP TT,MAKVC
LDSPC1: MOVE TT,T ;SAVE ADDRESS OF VALUE CELL
HRLM A,@LDAPTR ; IN ATOMTABLE
HRR TT,A ;AT LAST WE WIN
JRST LDABS
LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM]
TLNN D,777001 ;SKIP IF SPECIAL OR ALREADY USED
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
HRRI TT,(D) ;GET ADDRESS OF ATOM
JRST LDABS
SUBTTL QUOTED LIST REFERENCES
LDQLS: MOVSI D,11 ;[QUOTED LIST]
SKIPL LDPRLS(P) ;CAN'T COUNT ON ANYTHING IN PURE
MOVSI D,1 ; FREE STORAGE PROTECTING ANYTHING
PUSHJ P,LDLIST ;GOBBLE UP A LIST
MOVEM TT,(R) ;PUT WORD IN BPS
JSP T,LDGTWD ;GET HASH KEY FOR LIST
TLZ A,-1
SKIPE VGCPRO
JRST LDQLS4
PUSH FXP,D
PUSH FXP,AR1
TLZ A,-1
SKIPE D,TT
JRST LDQLS3
PUSH P,A
PUSHJ P,SXHSH0
POP P,A
LDQLS3: SKIPN V.PURE ;SKIP FOR PURE HACKERY
JRST LDQLS1
PUSH FXP,D ;SAVE HASH KEY
PUSH P,A ;SAVE LIST
MOVNI T,1 ;THIS MEANS JUST LOOKUP
PUSHJ P,LDGPRO
POP P,B
POP FXP,D
JUMPN A,LDQLS2 ;ON GCPRO LIST, SO USE IT
MOVE A,B
PUSHJ P,PURCOPY ;NOT ON GCPRO LIST, SO PURCOPY IT
LDQLS1: MOVEI T,1 ;THIS MEANS PROTECT OR HAND BACK COPY
PUSHJ P,LDGPRO ;PROTECT LIST FROM FEROCIOUS GC!
LDQLS2: POP FXP,AR1
POP FXP,D
LDQLS5: JUMPE D,LDEVL7 ;MAYBE THIS LIST GOES INTO ATOMTABLE
HRRM A,(R) ;SAVE ADDRESS OF LIST (WHICH MAY
JRST LDABS1 ; BE DIFFERENT NOW) BACK INTO WORD
LDQLS4: JSP T,LDQLPRO
JRST LDQLS5
LDQLPRO: HRRZ B,LDEVPRO ;GC-PROTECTON IS ACCOMPLISHED MERELY BY PUSHING ONTO A LIST
PUSHJ P,CONS
MOVEM A,LDEVPRO
JRST %CAR
LDGPRO: SKIPE GCPSAR ;PROTECT SOMETHING ON THE GCPSAR
JRST .GCPRO
PUSHJ P,.GCPRO ;FOO, THE LOOKUP WILL CAUSE THE CREATION OF A NEW ARRAY
JRST LDRSPT ;SO WE HAVE TO RESTORE PTRS AFTERWARDS
SUBTTL PURIFIABLE CALL
LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL]
TLNE D,777000
JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL
TLNE D,6
JSP D,LDFERR ;LOSE IF NUMBER
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
LDPRC1: TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL
JSP D,LDFERR
HRR TT,D ;PUT ADDRESS OF ATOM IN CALL
SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY
JRST LDABS ;OTHERWISE WE'RE DONE
TLNN T,200000 ;SKIP FOR XCT STUFF
SETZ T, ;ELSE DO ORDINARY SMASH
PUSHJ P,PRCHAK ;*** SMASH! ***
JRST LDABS1
MOVEI A,(R) ;NOT SMASHED - CONS ONTO PURE LIST
MOVE B,LDPRLS(P)
PUSHJ P,CONS
MOVEM A,LDPRLS(P)
JRST LDABS1
;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK.
;;; SKIPS ON *** FAILURE *** TO CLOBBER.
;;; T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH.
;;; TT HAS UUO INSTRUCTION TO HACK.
;;; R HAS ADDRESS TO PUT UUO INTO.
;;; MUST PRESERVE AR1, R, F.
PRCHAK: JUMPE T,LDPRC5 ;T ZERO => ORDINARY SMASH
MOVE T,TT ;SAVE CALL IN T
IDIV TT,LDXSM1 ;COMPUTE HASH CODE FOR CALL
MOVNM D,LDTEMP ;SAVE NEGATIVE THEREOF
HLRZ TT,LDXBLT
ADD D,TT ;ADDRESS TO BEGIN SEARCH
CAMN T,(D) ;WE MAY WIN IMMEDIATELY
JRST LDPRC7
SKIPN (D)
JRST LDPRC6
ADD TT,LDXSM1 ;ELSE MAKE UP AN AOBJN POINTER
SUBI TT,-1(D) ; AND SEARCH FOR MATCHING CALL
MOVNI TT,(TT)
HRL D,TT
LDPRC2: CAMN T,(D)
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC2
HRLZ D,LDTEMP ;WRAPPED OFF THE END OF THE XCT AREA
HLR D,LDXBLT ; - MAKE UP NEW AOBJN POINTER
LDPRC3: CAMN T,(D)
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC3
LDPRC4: MOVE TT,T ;TOTAL LOSS - MUST DO SMASH
LDPRC5: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A
MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE
JRST LDSMSH ;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
LDPRC6: SKIPG TT,LDXSIZ ;FOUND EMPTY SLOT
JRST LDPRC4 ;CAN'T USE IT IF PAGES PURIFIED
MOVEM T,(D) ;SAVE CALL INTO XCT AREA 2
SUBM D,TT
MOVEM T,(TT) ;ALSO SAVE INTO AREA 1
LDPRC7: SUB D,LDXSIZ ;MAKE UP AN XCT TO POINT TO
HRLI D,(XCT) ; CALL IN AREA 1
MOVEM D,(R)
POPJ P,
LDSMSH: MOVE T,(AR2A)
MOVEI A,(T)
LSH T,-33
CAIL T,CALL←-33
CAILE T,CALL←-33+NUUOCLS
POPJ P,
HRRZ A,(AR2A) ;SMASH A CALL/JCALL - AR2A HAS LOC OF CALL
MOVEI B,SBRL ;RETURN SKIPS IF IT CAN'T BE SMASHED
PUSHJ P,GETLA ;TRY TO GET SUBR, FSUBR, OR LSUBR PROP
LDB D,[<270400,,> (AR2A)] ;DESTROYS A,B,C,T,TT,D - SAVES AR1,AR2A [ARG],R,F
JUMPE A,LDSMNS
HLRZ B,(A)
MOVE T,[CAILE D,NACS]
CAIN B,QFSUBR
MOVE T,[CAIE D,17]
CAIN B,QLSUBR
MOVE T,[CAIE D,16]
XCT T
JRST POPJ1 ;LOSE IF WRONG NUMBER OF ARGS WANTED - SKIP RETURN
HRRZ A,(A) ;ELSE WIN - SMASH THE CALL
HLRZ A,(A) ;SUBR ADDRESS NOW IN A
SKIPA TT,(AR2A)
LDZAOK: HRLI A,(@) .SEE ASAR
MOVSI T,(PUSHJ P,) ;CALL BECOMES PUSHJ
TLNE TT,20000
ADDI A,1 ;HACK NCALLS CORRECTLY
TLNE TT,1000
MOVSI T,(JRST) ;JCALL BECOMES JRST
LDZA1: IOR T,A
MOVEM T,(AR2A) ;***SMASH!***
POPJ P,
LDSMNS: HRRZ A,(AR2A) ;TRY TO GET ARRAY PROPERTY
MOVEI B,QARRAY
PUSHJ P,GET
MOVEI T,(A)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,SA
JRST POPJ1 ;LOSE IF NOT SAR
LDB T,[TTSDIM,,TTSAR(A)]
CAIE T,(D) ;MUST HAVE CORRECT NUMBER OF ARGS
JRST POP1J
MOVSI T,TTS<CN>
IORM T,TTSAR(A) ;SET "COMPILED-CODE-NEEDS-ME" BIT.
MOVE TT,(AR2A)
TLNN TT,20000
JRST LDZAOK
MOVSI T,(ACALL)
TLNE TT,1000
MOVSI T,(AJCALL)
JRST LDZA1
SUBTTL GETDDTSYM HACKERY
LDGET: CAMN TT,XC-1
JRST LDLHRL
MOVE D,TT ;[GET DDT SYMBOL PATCH]
TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE?
JRST LDGET2
JSP T,LDGTWD ;FETCH IT THEN
SKIPE LDF2DP
JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER
LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL?
MOVNS TT
LDB D,[400200,,D] ;GET FIELD NUMBER
XCT LDXCT(D) ;HASH UP VALUE FOR FIELD
MOVE T,LDMASK(D) ;ADD INTO FIELD
ADD TT,-1(R) ; MASKED APPROPRIATELY
AND TT,T
ANDCAM T,-1(R)
IORM TT,-1(R)
JRST LDBIN
LDGET2: UNLOCKI ;UNLOCK INTERRUPTS
PUSH FXP,. ;RANDOM FXP SLOT
PUSH FXP,AR1 ;SAVE UP ACS
PUSH FXP,D
PUSH FXP,R
PUSH FXP,F
MOVEI R,0
TLZ D,740000
REPEAT LOG2LL5,[
CAML D,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
ADDI R,1←<LOG2LL5-.RPCNT-1>
] ;END OF REPEAT LOG2LL5
CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F)
MOVE TT,LSYMS(TT)
JRST LDGT5B
LDGT5A: MOVEI TT,R70
CAMN D,[SQUOZE 0,R70]
JRST LDGT5B
PUSHJ P,UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL
MOVEI C,(A)
MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY
PUSHJ P,GET
JUMPN A,LDGETJ ;WIN
IFN ITS,[
SKIPN LDDDTP(P) ;MAYBE WE CAN GET VALUE FROM DDT?
JRST LDGETX
LDB T,[004000,,-2(FXP)]
.BREAK 12,[..RSYM,,T]
JUMPE T,LDGETX ;LOSE, LOSE, LOSE
] ;END OF IFN ITS
IFN D10,[
SKIPN .JBSYM"
JRST LDGETX
LDB D,[004000,,-2(FXP)]
LDGET4: MOVE TT,D
IDIVI D,50
JUMPE R,LDGET4
PUSHJ P,GETDD0
JRST LDGETX
] ;END OF IFN D10
LDGT5B: MOVEM TT,-4(FXP) ;WIN, WIN - USE RANDOM FXP SLOT
MOVEI A,-4(FXP) ; TO FAKE UP A FIXNUM
JRST LDGETJ
LDGETX: MOVEI A,(C)
PUSHJ P,NCONS
MOVEI B,QGETDDTSYM ;DO A FAIL-ACT
PUSHJ P,XCONS
PUSHJ P,LDGETQ
LDGETJ: POP FXP,F ;RESTORE ACS
POP FXP,R
POP FXP,D
POP FXP,AR1
PUSHJ P,LDLRSP ;LOCKI AND RESTORE ARRAY POINTERS
MOVE TT,(A)
PUSHJ P,TYPEP ;FIGURE OUT WHAT WE GOT BACK
POP FXP,-1(FXP) ;POP RANDOM SLOT (REMEMBER THE LOCKI!)
CAIN A,QFIXNUM
JRST LDGET1
LDGETV: CAIN A,QFLONUM ;USE A FLONUM IF WE GET ONE
JRST LDGET1
LDGETW: PUSHJ P,LDGDDT ;FOR ANYTHING ELSE TRY DDT AGAIN
MOVEM TT,LDDDTP(P)
JRST LDGET2
LDGET6: REPEAT 4,[<11←24.>+<<<3-.RPCNT>*11>←30.> LAP5P(R)
]
IFN ITS,[
LDGDDT: JSP T,SIDDTP
JRST ZPOPJ ;0 => TOP LEVEL, OR NOT INFERIOR TO DDT
.BREAK 12,[..RSTP,,TT] ;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE
SKIPN TT ;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE
TLOA TT,-1
MOVSI TT,1
POPJ P,
] ;END OF IFN ITS
IFN D10,[
LDGDDT: SKIPE TT,.JBSYM"
MOVSI TT,1
POPJ P,
] ;END OF IFN D10
LDXCT: MOVSS TT ;INDEX FIELD
HRRZS TT ;ADDRESS FIELD
LSH TT,23. ;AC FIELD
JFCL ;OPCODE FIELD
LDMASK: -1 ;INDEX FIELD
0,,-1 ;ADDRESS FIELD
0 17, ;AC FIELD
-1 ;OPCODE FIELD
LDLHRL: HRLZ TT,LDOFST
ADDM TT,-1(R)
JRST LDBIN
SUBTTL ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF
LDAREF: PUSH FXP,TT ;[ARRAY REFERENCE]
MOVE D,@LDAPTR
TLNN D,777001
TLO D,11
MOVEM D,@LDAPTR
MOVEI A,(D)
PUSHJ P,TTSR+1 ;NCALL TO TTSR
HLL TT,(FXP)
SUB FXP,R70+1
JRST LDABS
LDGLB: SKIPL TT ;[GLOBALSYM PATCH]
SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL
MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF
ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF
HRRM TT,-1(R) ; LAST WORD LOADED
JRST LDBIN
LDATM: LDB T,[410200,,TT] ;[ATOMTABLE ENTRY]
JRST @LDATBL(T)
LDATBL: LDATPN ;PNAME
LDATFX ;FIXNUM
LDATFL ;FLONUM
LDATBN ;BIGNUM
LDATPN: MOVEI D,(TT) ;[ATOMTABLE PNAME ENTRY]
PUSH FXP,R
CAILE D,LPNBUF
JRST LDATP2
MOVEI C,PNBUF-1
LDATP1: JSP T,LDGTWD
ADDI C,1
MOVEM TT,(C)
SOJG D,LDATP1
SETOM LPNF
JRST LDATP4
LDATP2: PUSH FXP,D
LDATP3: JSP T,LDGTWD
JSP T,FWCONS
PUSH P,A
SOJG D,LDATP3
POP FXP,T
MOVNS T
JSP R,LIST1
SETZM LPNF
LDATP4: PUSH FXP,AR1
PUSHJ P,RINTERN
POP FXP,AR1
POP FXP,R
LDATP8: MOVE TT,LDAAOB
MOVEM A,@LDAPTR
AOBJP TT,LDAEXT
MOVEM TT,LDAAOB
JRST LDBIN
LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FXP,TT
SKIPE A
LDATX0: TLOA A,10
JRST LDATX2
LDATX1: TLO A,2
JRST LDATP8
LDATX2: SKIPE V.PURE
JRST LDATX3
JSP T,FXCONS
JRST LDATX1
LDATX3: PUSHJ P,PFXCONS
JRST LDATX0
LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY]
PUSH FLP,TT
MOVEI A,(FLP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FLP,TT
SKIPE A
LDATL0: TLOA A,10
JRST LDATL2
LDATL1: TLO A,4
JRST LDATP8
LDATL2: SKIPE V.PURE
JRST LDATL3
JSP T,FLCONS
JRST LDATL1
LDATL3: PUSHJ P,PFLCONS
JRST LDATL0
LDATBN:
IFE BIGNUM, JRST FASBNE
IFN BIGNUM,[
PUSH FXP,TT ;[ATOMTABLE BIGNUM ENTRY]
MOVEI D,(TT)
MOVEI B,NIL
LDATB1: JSP T,LDGTWD
SKIPE V.PURE
JRST LDATB2
JSP T,FWCONS
PUSHJ P,CONS
JRST LDATB3
LDATB2: PUSHJ P,PFXCONS
PUSHJ P,PCONS
LDATB3:
MOVE B,A
SOJG D,LDATB1
POP FXP,TT
TLNE TT,1
TLO A,-1
SKIPE V.PURE
JRST LDATB6
PUSHJ P,BNCONS
JRST LDATB7
LDATB6: PUSHJ P,PBNCONS
TLO A,10
LDATB7:
TLO A,6
JRST LDATP8
] ;END OF IFN BIGNUM
LDAEXT: MOVE T,TT ;[ATOMTABLE EXTEND]
HRLI T,-ILDAT
MOVEM T,LDAAOB
ADDI TT,ILDAT
ASH TT,1
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
PUSH P,[LDRFRF]
PUSH P,LDASAR
PUSH P,[TRUTH]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,A
MOVNI T,3
JRST .REARRAY
LDRFRF: PUSHJ P,LDRSPT ;[RETURN FROM .REARRAY FUNCTION]
LDRSTX: SUB FXP,R70+1
POP FXP,F
POP FXP,R
POP FXP,AR1
JRST LDBIN
SUBTTL ENTRY POINT
LDENT: HRRZ C,@LDAPTR ;[ENTRY POINT INFO]
MOVSS TT
HRRZ A,@LDAPTR
PUSH P,A
PUSH P,C
SKIPN VFASLOAD
JRST LDNRDF
MOVEI B,SBRL
PUSHJ P,GETLA
JUMPE A,LDNRDF
PUSH P,A
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
PUSHJ P,IOGBND
STRT [SIXBIT \↑M;CAUTION#! !\]
MOVE A,-2(P)
PUSHJ P,PRIN1
HRRZ B,@(P)
HLRZ B,(B)
MOVEI TT,[SIXBIT \, A SYSTEM !\]
10% CAIL B,ENDFUN
10$ CAIGE B,BEGFUN
MOVEI TT,[SIXBIT \, A USER !\]
STRT (TT)
HLRZ A,@(P)
PUSHJ P,PRIN1
STRT [SIXBIT \ AT !\]
HRRZ TT,@(P)
HLRZ TT,(TT) ;USE OF PRINL4 HERE DEPENDS ON PRIN1
PUSHJ P,PRINL4 ; LEAVING ADDRESS OF TYO IN R
STRT [SIXBIT \, IS BEING REDEFINED↑M; AS A !\]
HRRZ A,-1(P)
PUSHJ P,PRIN1
STRT [SIXBIT \ BY FASL FILE !\]
MOVE A,LDFNAM
PUSHJ P,PRIN1
PUSHJ P,TERPRI
PUSHJ P,UNBIND
POP FXP,F
POP FXP,R
POP FXP,AR1
SUB P,R70+1
LDNRDF: MOVE B,(P)
MOVE A,-1(P)
PUSHJ P,REMPROP
POP P,C
MOVE A,(P)
JSP T,LDGTWD
PUSH FXP,TT
MOVEI B,@LDOFST
CAILE B,(R)
JSP D,LDFERR
PUSHJ P,PUTPROP
POP FXP,TT
HLRZ T,TT
HLRZ B,@(P)
HLRZ D,1(B)
CAIN D,(T) ;NEEDN'T DO IT IF ALREADY SAME
JRST LDPRG3
LDPARG: ;ELSE TRY TO CLOBBER IT IN
PURTRAP LDPRG9,B, HRLM T,1(B)
LDPRG3: SUB P,R70+1
JRST LDBIN
SUBTTL PUTDDTSYM FROM FASL FILE
;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS:
;;; 4.9 1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE
;;; 4.8 LH IS RELOCATABLE
;;; 4.7 RH IS RELOCATABLE
;;; 4.6 IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT)
IFN ITS,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3 ;FORGET IT IF SYMBOLS NOT NON-NIL
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000 ;IF HAS 'SYMBOLS, LOAD ONLY GLOBALS
JRST LDPUT3
LDPUT7: JUMPL TT,LDPUT2
MOVEI D,(R)
LDPUT0: TLZ TT,740000
TLO TT,%SYGBL
SKIPG A,LDDDTP(P)
JRST LDBIN ;FORGET IT IF DDT HAS NO SYMBOL TABLE
MOVE T,TT
TRNE A,-1 ;MAY HAVE TO CREATE SYMBOL TABLE ARRAY
JRST LDPUT5
UNLOCKI
PUSH FXP,AR1
PUSHJ P,SAVX5
MOVEI TT,LLDSTB*2+1
MOVSI A,-1
PUSHJ P,MKFXAR
PUSHJ P,RSTX5
POP FXP,AR1
PUSHJ P,LDLRSP
HRRM A,LDDDTP(P)
LDPUT4: MOVSI TT,-LLDSTB ;USE TT FOR TWO THINGS HERE!
MOVEM TT,@TTSAR(A)
LDPUT5: SETZ TT,
AOS TT,@TTSAR(A) ;GET AOBJN POINTER
JUMPGE TT,LDPUT4
MOVEM T,@TTSAR(A) ;SAVE SQUOZE FOR SYMBOL
ADD TT,R70+1
MOVEM D,@TTSAR(A) ;SAVE ITS VALUE
MOVE T,TT
SETZ TT,
MOVEM T,@TTSAR(A) ;SAVE BACK INCREMENTED AOBJN PTR
JUMPL T,LDBIN
PUSHJ P,LDPUTM ;MAY BE TIME TO OUTPUT BUFFER
JRST LDBIN
LDPUTM: SETZ TT,
MOVN T,@TTSAR(A)
MOVSI T,(T)
HRR T,TTSAR(A)
AOSGE T
.BREAK 12,[..SSTB,,T]
POPJ P,
] ;END OF IFN ITS
IFN D10,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000
JRST LDPUT3
LDPUT7: SKIPN .JBSYM"
JRST LDPUT3
PUSH FXP,AR1
JUMPL TT,LDPUT2
MOVE D,R
LDPUT0: PUSH FXP,D
PUSH FXP,F
TLZ TT,740000
LDPUT1: MOVE T,TT
IDIVI TT,50
JUMPE D,LDPUT1
MOVEI B,-1(FXP)
MOVSI R,400000
PUSHJ P,PUTDD0
JRST LDRSTX
] ;END OF IFN D10
LDPUT2: MOVE D,TT
JSP T,LDGTWD
EXCH TT,D
TLNN TT,100000
JRST LDPT2A
MOVE T,LDOFST
ADD T,D
HRRM T,D
LDPT2A: TLNN TT,200000
JRST LDPT2B
HRLZ T,LDOFST
ADD D,T
LDPT2B: TLZ T,740000
TLO T,%SYGBL+%SYHKL ;GLOBAL AND HALF-KILLED
JRST LDPUT0
LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT
JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD
JRST LDBIN
LDLOC: MOVEI TT,@LDOFST
MOVEI D,(R)
CAMLE D,LDHLOC
MOVEM D,LDHLOC
CAMG TT,LDHLOC
JRST LDLOC5
MOVE D,LDHLOC
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRR R,LDHLOC
SETZ TT,
SUB F,R70+1 ;BEWARE THIS BACK-UP CROCK!
ADD AR1,[040000,,]
JRST LDABS
LDLOC5: HRRZ D,LDOFST
CAIGE TT,(D)
JSP D,LDFERR
MOVEI D,(TT)
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRRI R,(TT)
JRST LDBIN
SUBTTL EVALUATE MUNGEABLE
LDEVAL: SETZ D, ;[EVALUATE MUNGEABLE]
PUSHJ P,LDLIST ;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE
PUSH P,A
PUSHJ P,LDEV0
SUB P,R70+1
Q$ JUMPN D,LDGTSP ;MIGHT HAVE DONE A FASLOAD WITHIN A FASLOAD
Q% JUMPN D,LDBIN
JSP T,LDQLPRO ;PUSHES GOODY ONTO THE LDEVPRO LIST
LDEVL7: TLO A,16 ;AND GOES OFF TO ENTER INTO THE ATOMTABLE
JRST LDATP8
LDEV0: UNLOCKI ;EVALUATES AN S-EXPRESSION IN A
IFN QIO,[
JUMPE D,LDEV2 ;IN QIO, ALLOWS FOR RECURSIVE FASLOADING
SETZM FASLP ;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE
PUSH P,A
MOVEI TT,(R)
JSP T,FXCONS
MOVEM A,VBPORG
MOVE A,LDPRLS-3(P)
TLNN A,600000
HRRZM A,VPURCLOBRL
HRRZ TT,LDOFST
SUBI TT,(R)
HRRM TT,LDOFST
MOVNI T,LFTMPS
PUSH FXP,BFTMPS+LFTMPS(T)
AOJL T,.-1
POP P,A
LDEV2:
] ;END OF IFN QIO
SAVEFX AR1 D R F
PUSHJ P,EVAL
RSTRFX F R D AR1
IFN QIO,[
JUMPE D,LDLRSP
HRRZ B,LDBGEN-2(P)
MOVEM B,FASLP
MOVEI T,LFTMPS-1
POP FXP,BFTMPS(T)
SOJGE T,.-1
HRRZ TT,LDOFST
ADD TT,@VBPORG
HRRM TT,LDOFST
HRRZ B,VPURCLOBRL
HRRM B,LDPRLS-2(P)
] ;END OF IFN QIO
JRST LDLRSP ;EXIT
SUBTTL END OF FASLOAD FILE
LDBEND: TRZ TT,1 ;CROCK!
CAME TT,[SIXBIT \*FASL*\]
JSP D,LDFERR
MOVEI TT,LDFEND
MOVEM TT,LDEOFJ
IFN ITS,[
SKIPLE A,LDDDTP(P)
TRNN A,-1
CAIA
PUSHJ P,LDPUTM ;MAYBE HAVE TO FORCE LDPUT'S BUFFER
] ;END OF IFN ITS
HLLZS LDDDTP(P) ;WILL USE FOR SWITCH LATER
JSP T,LDGTWD
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\]
JRST LDBEN1
HLLOS LDDDTP(P)
MOVEM F,LDTEMP
JRST LDFEND
LDBEN1: TRZ TT,1
CAME TT,[14060301406]
10% JSP D,LDFERR
10$ JUMPN TT,LDFERR
LDFEND: MOVEI TT,(R) ;END OF FILE
CAMGE R,LDHLOC
MOVE R,LDHLOC
JSP T,FWCONS
IFE ITS, MOVEM A,VBPORG ;UPDATE BPORG
IFN ITS,[
MOVE D,(A)
EXCH A,VBPORG
MOVE TT,(A)
SKIPL LDPRLS(P)
JRST LDZPUR
HLLOS NOQUIT
ANDI TT,PAGMSK
ANDI D,PAGMSK
LSHC TT,-PAGLOG
SUBI D,(TT)
ROT TT,-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[450200,,PURTBL]
MOVEI T,1
LDNPUR: TLNN TT,730000
TLZ TT,770000
IDPB T,TT
SOJGE D,LDNPUR
PUSHJ P,CZECHI
LDZPUR:
] ;END OF IFN ITS
;FALLS THROUGH
;FALLS IN
PUSH FXP,F ;SAVE POINTER TO I/O BUFFER
HRRZ F,LDAAOB
LDGCPR: SOJLE F,LDSDPL ;[GC PROTECT AS YET UNPROTECTED ATOMS]
SKIPE INTFLG
PUSHJ P,LDTRYI
MOVEI TT,(F)
MOVE AR2A,@LDAPTR
HRRZ A,AR2A
JUMPE A,LDGCPR ;LOSING MIDAS!
TLNN AR2A,777000
TLNN AR2A,6
JRST LDGCP4
TLNN AR2A,10
TLNN AR2A,1
JRST LDGCPR
LDGCP1: HRRZ A,AR2A
CAIGE A,IN0+XHINUM
CAIGE A,IN0-XLONUM
PUSHJ P,%GCPRO ;IF FOR SOME REASON, THIS CAUSES THE CREATION OF THE GCPSAR
JRST LDGCPR ;I STILL DONT THINK WE NEED TO RESTORE PTRS HERE
LDGCP4: HLRZ B,(A) ;CONSIDER SETTING THE "COMPILED CODE
MOVE R,(B) ; NEEDS ME" BIT IN THE SYMBOL BLOCK
TLO R,100 ;SO FAR, SO GOOD
TLNN R,200 ;BUT CAN'T DO IT FOR A PURE BLOCK!
MOVEM R,(B)
JRST LDGCPR
SUBTTL SMASH DOWN PURE LIST
LDSDPL: SKIPL TT,LDPRLS(P) ;[SMASH DOWN PURE LIST]
TLNE TT,200000
JRST LDEOMM
MOVEM TT,VPURCLOBRL
MOVEI F,VPURCLOBRL
LDSDP1: SKIPN TT,LDPRLS(P)
JRST LDEOMM
SKIPN INTFLG
JRST LDSDP2
SKIPE INTFLG
PUSHJ P,LDTRYI
LDSDP2: HRRZ T,(TT)
MOVEM T,LDPRLS(P)
HLRZ AR2A,(TT)
PUSHJ P,LDSMSH
JRST LDSDP3
HRRZ F,(F)
JRST LDSDP1
LDSDP3: MOVE TT,LDPRLS(P)
HRRM TT,(F)
JRST LDSDP1
SUBTTL END OF FASLOAD, AND RANDOM ROUTINES
LDEOMM: POP FXP,LDTEMP ;GET POINTER TO I/O BUFFER
MOVE TT,LDDDTP(P)
Q$ MOVE A,LDBGEN(P)
SUB P,R70+LDNPDS ;[END OF MOBY MESS!!!]
TRNE TT,-1
JRST LDEOM1
Q$ PUSHJ P,$CLOSE ;CLOSE FILE ARRAY
Q% 10% .CLOSE DSIC,
Q% 10$ RELEASE DSIC,
MOVE A,VBPORG
UNLOCKI
PUSHJ P,UNBIND
HRRZ TT,-2(P) ;FOR DEBUGGING PURPI,
HRRZ D,-1(P) ; MAKE SURE PDLS ARE OKAY
HRRZ R,(P)
SUB P,R70+3
JRST PDLCHK
LDEOM1: UNLOCKI
Q$ PUSH P,A ;PUT LDBSAR BACK ON PDL
JRST LDDISM
LDTRYI: UNLOCKI ;[TRY AN INTERRUPT]
LDLRSP: LOCKI ;[LOCKI AND RESTORE POINTERS]
LDRSPT: HRRZ TT,LDASAR ;[RESTORE ARRAY POINTERS]
HRRZ TT,TTSAR(TT)
HRRM TT,LDAPTR
HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
HRRM TT,LDBPTR
POPJ P,
LDLIS0: JSP T,LDGTWD
LDLIST: LDB T,[410300,,TT] ;[CONSTRUCT LIST]
JRST LDLTBL(T)
LDLTBL: JRST LDLATM ;ATOM
JRST LDLLST ;LIST
JRST LDLDLS ;DOTTED LIST
JRST LDOWL
IFN HNKLOG, JRST LDLHNK ;HUNK
.ELSE JRST FASHNE
REPEAT 2, .VALUE
JRST LDLEND ;END OF LIST
LDLATM: MOVE A,@LDAPTR ;FOR ATOM, MAYBE SET USAGE BIT,
TLNN A,777011 ; THEN SHOVE ON STACK
IOR A,D
MOVEM A,@LDAPTR
PUSH P,A
JRST LDLIS0
LDLLST: TDZA A,A ;FOR LIST, USE NIL AS END
LDLDLS: POP P,A ;FOR DOTTED LIST, USE TOP ITEM
HRRZS TT
JUMPE TT,LDLLS3
LDLLS1: POP P,B ;NOW POP N THINGS AND CONS THEM UP
PUSHJ P,XCONS
SOJG TT,LDLLS1
LDLLS3: PUSH P,A
SKIPE INTFLG
PUSHJ P,LDTRYI
JRST LDLIS0
LDOWL: MOVE A,(P)
PUSHJ P,LDEV0
MOVEM A,(P)
JRST LDLIS0
IFN HNKLOG,[
LDLHNK: MOVEI T,-1(TT)
JSP AR2A,HUNKF0
PUSH P,A
JRST LDLIS0
] ;END OF IFN HNKLOG
LDLEND: HLRZ D,TT
TRC D,777776
TRNE D,777776
JSP D,LDFERR
POP P,A
MOVSS TT
HRRI TT,(A)
POPJ P,
;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER
;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY
;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS
;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS.
;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE
;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY
;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS
;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S.
ZZ==-1
ZZZ==0
;;; BIBOP USED TO BE THE 3RD NUMBER HERE
IRP X,,[D10,ML,1,BIGNUM,MOBIOF]
ZZ==ZZ←1
ZZZ==<ZZZ←1>\X
TERMIN
LDFNM2: <.FNAM2&ZZ>\ZZZ
EXPUNGE ZZ ZZZ
IFE QIO,[
LDFNSET: MOVE A,LDFNAM
JSP T,LNG1A ;GETS LENGTH OF ARG
MOVE A,LDFNAM
CAIN TT,4
POPJ P,
CAIGE TT,2
JRST SCRFUN ;COMPUTES STANDARD FILE SPECIFICATION LIST
JSP T,%CADR ;FROM INPUT ARG
MOVE B,IUNIT
PUSHJ P,CONS
HLRZ B,@LDFNAM
JRST XCONS
] ;END OF IFE QIO
IFE QIO,[
LDGTW0: HRLZI F,-LLDBF ;RESET THE POINTER AND THIS TIME GET A REAL DATA WORD
LDGTWD: MOVE TT,@LDBPTR ;PICK UP WORD FROM INPUT BUFFER
AOBJN F,(T) ;RETURN WITH WORD
LDGTW1: MOVE F,@LDBSAR .SEE ASAR
MOVE F,-1(F) ;THAT WAS NO DATA WORD - MUST GET MORE
IFN ITS,[
ADD F,[1,,]
MOVE TT,F
.IOT DSIC,F
TLNN F,-1 ;SKIP IF WE DIDNT GET A WHOLE BUFFERFUL
JRST LDGTW0
CAMN F,TT ;SKIP IF WE GOT AT LEAST ONE WORD
JSP D,@LDEOFJ ;OTHERWISE GO CRY A LOT, OR SOMETHING
HLRES F ;CALCULATE POINTER FOR THE PARTIAL BLOCK
ADDI F,LLDBF
MOVNS F
HRLZS F
JRST LDGTWD ;NOW GO GET A REAL DATA WORD
] ;END OF IFN ITS
IFN D10,[
ADDI F,-1 ;SIMULTANEOUS +1 IN LH -1 IN RH
MOVEM F,D10ARD ;SAVE IN I/O LIST
IFN SAIL,[
PUSH FXP,D
PUSH FXP,R
HRRZ D,D10ARD
AOJ D, ;D10ARD POINTS TO ADDRESS BEFORE
HRLI D,-1(D)
AOBJN D,.+1 ;CONS UP BLT PTR
SETZM -1(D) ;ZERO FIRST WORD
MOVEI R,200-1(D) ;CALCULATE END-WORD ADDR
BLT D,(R) ;BLLLLLLLLLLLLLLLLLLLL. . .LLLLLT
POP FXP,R
POP FXP,D
] ;END OF IFN SAIL
IN DSIC,D10ARD
JRST LDGTW0
IFN SAIL,[
SKIPE SAILFL ;FLAG SET?
JRST .+3 ;NO, THEN WE GOT STUFF FROM DSK
AOS SAILFL ;YES, SET FLAG IN CASE WE ASK FOR MORE LATER
JRST LDGTW0
] ;END OF IFN SAIL
JSP D,@LDEOFJ
] ;END OF IFN D10
] ;END OF IFE QIO
IFN QIO,[
LDGTW0: MOVE F,[-XDIB.BS,,FB.BUF]
LDGTWD: MOVE TT,@LDBPTR
AOBJN F,(T)
LDGTW1: HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
MOVE F,FB.IOT(TT)
ADD F,[1,,]
.CALL LDGTW9
.VALUE
TLNN F,-1
JRST LDGTW0
SUB F,[1,,]
CAMN F,FB.IOT(TT)
JSP D,@LDEOFJ
HLRZ TT,FB.IOT(TT)
HLRES F
SUBI F,-1(TT)
MOVNS F
HRLZS F
HRRI F,FB.BUF
JRST LDGTWD
LDGTW9: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
400000,,F ;BLOCK POINTER
] ;END OF IFN QIO
PGTOP FSL,[FASLOAD]
;;@ END OF FASLOA 89
IFN QIO,[
;;@ QIO 248 NEW MULTIPLE FILE I/O FUNCTIONS
PGBOT [QIO]
SUBTTL I/O CHANNEL ALLOCATOR
;;; ALCHAN ALLOCATES AN I/O CHANNEL FOR USE. IT EXPECTS THE
;;; SAR FOR THE FILE ARRAY TO BE IN A, AND RETURNS THE
;;; CHANNEL NUMBER IN F, SKIPPING IF SUCCESSFUL.
;;; THE FILE ARRAY MUST HAVE ITS TTS.CL BIT SET.
;;; USER INTERRUPTS TURNED OFF, PLEASE. CLOBBERS R.
;;; MAY INVOKE A GARBAGE COLLECTION TO FREE UP CHANNELS.
ALCHAN: HRRZS (P)
ALCHN0: MOVEI F,LCHNTB-1 ;SCAN CHANNEL TABLE
ALCHN1: SKIPN R,CHNTB(F)
JRST ALCHN3 ;FOUND A FREE CHANNEL
MOVE R,TTSAR(R)
TLNE R,TTS<CL>
JRST ALCHN2 ;SEMI-FREE CHANNEL
SOJG F,ALCHN1 ;NOT SOJGE - TMPC NEVER FREE
SKIPGE (P) ;SKIP IF FIRST TIME
POPJ P, ;LOSEY LOSEY
HRROS (P) ;SET SWITCH
PUSH P,[555555,,ALCHN0]
JRST AGC ;HOPE GC WILL RECLAIM A FILE ARRAY
ALCHN2: .CALL ALCHN9 ;CLOSE CHANNEL TO BE SURE
.VALUE
ALCHN3: MOVE R,TTSAR(A) ;INSTALL CHANNEL NUMBER
MOVEM F,F.CHAN(R)
MOVEM A,CHNTB(F) ;RESERVE CHANNEL
JRST POPJ1 ;WIN WIN - SKIP RETURN
ALCHN9: SETZ
SIXBIT \CLOSE\ ;CLOSE I/O CHANNEL
400000,,F ;CHANNEL #
;;; ALFILE CREATES A MINIMAL FILE ARRAY (OF LENGTH LOPOFA),
;;; ALLOCATES A CHANNEL, AND PUTS THE CHANNEL NUMBER INTO
;;; THE F.CHAN SLOT OF THE FILE ARRAY. IT EXPECTS A LEFT-
;;; JUSTIFIED DEVICE NAME IN TT WHICH IS INSTALLED IN THE
;;; F.DEV SLOT OF THE FILE ARRAY. THIS IS USEFUL FOR ROUTINES
;;; WHICH WANT TO HACK ON A RANDOM CHANNEL BUT DON'T NEED
;;; A FULL-BLOWN FILE ARRAY. A FILE ARRAY IS NEEDED FOR
;;; THE SAKE OF THE CHANNEL TABLE (CHNTB) AND FOR THE GARBAGE
;;; COLLECTOR; IF THE FILE ARRAY IS GARBAGE COLLECTED, SO IS
;;; THE ASSOCIATED CHANNEL. THE FILE ARRAY ALSO MUST
;;; CONTAIN AT LEAST A DEVICE NAME SO PRIN1 CAN WIN.
;;; CLOBBERS PRACTICALLY ALL ACS.
;;; THE ARRAY GC POINTER IS SET TO PROTECT THE FIRST SLOT ONLY.
;;; RETURNS FILE ARRAY IN A, CHANNEL NUMBER IN F.
;;; SKIPS ON SUCCESS; FAILS IF ALCHAN CAN'T GET A CHANNEL.
ALFILE: LOCKI
PUSH FXP,TT
MOVEI TT,LOPOFA ;LENGTH OF PLAIN OLD FILE ARRAY
MOVSI A,-1 ;GET ONLY A SAR
PUSHJ P,MKLSAR
MOVSI TT,TTS<CL> ;SET CLOSED BIT
IORB TT,TTSAR(A)
MOVSI T,AS<FIL> ;SET FILE ARRAY BIT (MUST DO
IORB T,ASAR(A) ; IN THIS ORDER!)
HRROS -1(T)
POP FXP,T
MOVEM T,F.DEV(TT) ;INSTALL DEVICE NAME
MOVEM T,F.RDEV(TT)
MOVSI T,FBT.CM ;PREVENT GC FROM TRYING TO
MOVEM T,F.MODE(TT) ; UPDATE NONEXISTENT POINTERS
PUSHJ P,ALCHAN
JRST UNLKPJ
AOS (P) ;WE SKIP IFF ALCHAN DOES
MOVSI TT,TTS<CL>
ANDCAM TT,TTSAR(A)
UNLKPJ: UNLKPOPJ
SUBTTL FILE OBJECT CHECKING ROUTINES
;;; JSP TT,XFILEP
;;; SKIPS IFF THE OBJECT IN AR1 IS A FILE ARRAY. CLOBBERS R.
AFILEP: MOVEI AR1,(A)
XFILEP: MOVEI R,(AR1)
LSH R,-SEGLOG
MOVE R,ST(R)
TLNN R,SA
JRST (TT)
MOVE R,ASAR(AR1) ;MUST ALSO HAVE FILE BIT SET
TLNN R,AS<FIL>
JRST (TT)
JRST 1(TT)
;;; THESE ROUTINES ACCEPT A FILE ARRAY IN AR1 AND CHECK WHETHER
;;; IT IS OF THE DESIRED TYPE. IF NOT, A WTA ERROR OCCURS.
;;; LEAVES TTSAR IN TT AND USER INTS LOCKED IF SUCCESSFUL.
;;; CLOBBERS T, TT, AND R. SAVES D (SEE FILEPOS) AND F.
OFILOK: JSP T,FILOK0 ;TYPICAL INVOCATION:
TTS<IO>,,TTS<IO> ; DESIRED BITS,,MASK
SIXBIT \NOT OUTPUT FILE!\ ; ERROR MSG IF FAIL
IFILOK: JSP T,FILOK0
0,,TTS<IO>
SIXBIT \NOT INPUT FILE!\
ATFLOK: JSP T,FILOK0
0,,TTS<BN>
SIXBIT \NOT ASCII FILE!\
ATOFOK: JSP T,FILOK0
TTS<IO>,,TTS<BN+IO>
SIXBIT \NOT ASCII OUTPUT FILE!\
ATIFOK: JSP T,FILOK0
0,,TTS<BN+IO>
SIXBIT \NOT ASCII INPUT FILE!\
TFILOK: JSP T,FILOK0
TTS<TY>,,TTS<TY>
SIXBIT \NOT TTY FILE!\
TIFLOK: JSP T,FILOK0
TTS<TY>,,TTS<TY+IO>
SIXBIT \NOT TTY INPUT FILE!\
TOFLOK: JSP T,FILOK0
TTS<TY+IO>,,TTS<TY+IO>
SIXBIT \NOT TTY OUTPUT FILE!\
XIFLOK: JSP T,FILOK0
TTS<BN>,,TTS<IM+BN+TY+IO>
SIXBIT \NOT BINARY INPUT FILE!\
XOFLOK: JSP T,FILOK0
TTS<BN+IO>,,TTS<IM+BN+TY+IO>
SIXBIT \NOT BINARY OUTPUT FILE!\
FILOK: JSP T,FILOK0
0,,0
NFILE: SIXBIT \NOT FILE!\
FILOK0: LOCKI
CAIE AR1,TRUTH ;T => TTY FILE ARRAY
JRST FILOK1
MOVSI TT,TTS<IO>
TSNE TT,(T) ;IF DON'T CARE ABOUT I/O
TDNE TT,(T) ; OR SPECIFICALLY WANT OUTPUT
SKIPA AR1,V%TYO ; THEN USE TTY OUTPUT
HRRZ AR1,V%TYI ;USE TTY INPUT ONLY IF NECESSARY
FILOK1: JSP TT,XFILEP ;SO IS IT A FILE ARRAY?
JRST FILNOK ;NOPE - LOSE
MOVE TT,TTSAR(AR1)
XOR TT,(T)
HLL T,TT
MOVE TT,TTSAR(AR1) ;WANT TO RETURN TTSAR IN TT
TLNE T,@(T)
JRST FILNOK
TLNN TT,TTS<CL>
POPJ P, ;YEP - WIN
SKIPA TT,[[SIXBIT \FILE HAS BEEN CLOSED!\]]
FILNOK: MOVEI TT,1(T)
EXCH A,AR1
UNLOCKI
%WTA (TT)
EXCH A,AR1
JRST FILOK0
SUBTTL CONVERSION: NAMELIST => SIXBIT
;;; A NAMELIST IN A IS CONVERTED TO FOUR SIXBIT WORDS ON
;;; THE FIXNUM PDL IN THE ORDER
;;; <DEVICE> <SNAME/PPN> <FILE NAME 1> <FILE NAME 2>
;;; THERE ARE TWO KINDS OF NAMELIST: SHORT AND FULL.
;;; A SHORT NAMELIST IS UREAD-STYLE: TWO FILE NAMES, A DEVICE
;;; NAME, AND AN SNAME/PPN. A FULL NAMELIST HAS THE DEVICE
;;; AND SNAME/PPN IN THE CAR (WHICH IS NON-ATOMIC) AND THE
;;; FILE NAMES ON THE CDR.
NML6BT: JSP T,QIOSAV
NML6B5: PUSH P,A
HLRZ A,(A)
PUSHJ P,ATOM
JUMPN A,NML6B2
HLRZ A,@(P)
PUSHJ P,NML6DV ;SKIPS IF OKAY
JRST NML6B0
HRRZ A,@(P)
PUSHJ P,NML6FN
JUMPE A,POP1J
NML6BZ: SUB FXP,R70+2
NML6B0: SUB FXP,R70+2
POP P,A
WTA [INCOMPREHENSIBLE NAMELIST!]
JRST NML6B5
NML6B2: HRRZ A,(P) ;SUBROUTINE - STACKS UP TWO GOODIES ON FXP
PUSHJ P,NML6FN
MOVSI T,(SIXBIT \*\)
MOVSI TT,(SIXBITY \*\)
JUMPE A,NML6B3
PUSHJ P,NML6DV ;SKIPS IF OKAY
JRST NML6BZ
POP FXP,TT
POP FXP,T
NML6B3: EXCH T,-1(FXP)
EXCH TT,(FXP)
PUSH FXP,T
PUSH FXP,TT
JRST POP1J
NML6FN:
REPEAT 2, PUSH FXP,[SIXBIT \*\]
JUMPE A,FALSE
MOVEI B,IN0+10.
JSP T,SPECBIND
0 B,VBASE
0 B,V.NOPOINT
PUSH P,CUNBIND
MOVEI B,(A)
PUSHJ P,ATOM
EXCH B,A
JUMPE B,NML6F2
NML6F1: PUSHJ P,SIXMAK
MOVEM TT,(FXP)
JRST FALSE
NML6F2: PUSH P,A
HLRZ A,(A)
PUSHJ P,SIXMAK
MOVEM TT,-1(FXP)
HRRZ A,@(P)
JUMPE A,POP1J
MOVEM A,(P)
PUSHJ P,ATOM
JUMPE A,NML6F3
POP P,A
JRST NML6F1
NML6F3: HLRZ A,@(P)
PUSHJ P,NML6F1
HRRZ A,@(P)
JRST POP1J
NML6DV:
REPEAT 2, PUSH FXP,[SIXBIT \*\]
HRRZ B,(A)
HLRZ A,(A)
PUSH P,B
HRRZ TT,(B)
JUMPN TT,POP1J
AOS -1(P)
10% JUMPE B,IDND
PUSHJ P,SIXMAK
MOVEM TT,-1(FXP)
HLRZ A,@(P)
10% PUSHJ P,SIXMAK
IFN D10,[
IFE SAIL,[
JSP T,SPATOM
JRST .+3
PUSHJ P,SIXMAK ;SIXBIT PPN
JRST NML6D1
HLRZ B,(A)
JSP T,FXNV2 ;PROJ # IN D
HRRZ A,(A)
HLRZ A,(A)
JSP T,FXNV1 ;PROG # IN TT
HRLI TT,(D)
NML6D1:
] ;END OF IFE SAIL
IFN SAIL,[
HLRZ B,(A) ;PROJ# IN B
HRRZ A,(A)
HLRZ A,(A) ;PROG# IN A
PUSH P,B ;LH PART ON PDL
PUSHJ P,SIXMAK ;GET SIXBIT FOR RH PART
PUSHJ P,SARGT ;RIGHT JUSTIFY BOX
PUSH FXP,TT ;ON ANOTHER STACK
POP P,A ;LH IN A
PUSHJ P,SIXMAK ;GET SIXBIT FOR LH
PUSHJ P,SARGT ;R.J.
POP FXP,D
HLR TT,D ;INSTALL RH PART
] ;END OF IFN SAIL
] ;END OF IFN D10
IDNDSN: MOVEM TT,(FXP)
JRST POP1J
IFN SAIL,[
SARGT: TLNE TT,77 ;IS RIGHTMOST CHAR ZERO?
POPJ P, ;WIN
LSH TT,-6 ;SLYDE RIGHT
JRST SARGT ;ONE MORE TIME, NOW.
] ;END OF IFN SAIL
IFN ITS,[
;;; INSUFFERABLE DEVICE NAME DISTINGUISHER
IDND: PUSHJ P,SIXMAK
TRNE TT,-1
JRST IDNDSN
TLC TT,77 ;SIXBIT 77 = BACKARROW
TLCN TT,77
JRST IDNDSN
HLRZ D,TT
MOVEI R,(D)
ANDI R,7777
CAIG R,3177 ;SIXBIT 31 = 9
CAIGE R,2000 ;SIXBIT 20 = 0
CAIA
TRO D,7700
ANDI R,77
CAIG R,31
CAIGE R,20
CAIA
TRO D,77
MOVE R,[442200,,DEVNMS]
IDND2: ILDB T,R
JUMPE T,IDNDSN ;SIGH - MUST BE SNAME AFTER ALL
CAIE T,(D)
JRST IDND2
MOVEM TT,-1(FXP) ;IT'S A DEVICE NAME!
JRST POP1J
DEVNMS: SIXBIT \DSKSYS\
SIXBIT \COMAI \
SIXBIT \ML DM \
SIXBIT \TTYT←←\
SIXBIT \TY←STY\
SIXBIT \ST←S←←\
SIXBIT \PK←P←←\
SIXBIT \DK←UT←\
SIXBIT \MT←NUL\
SIXBIT \AR←DIR\
SIXBIT \LPTTPL\
SIXBIT \CLOCLU\
SIXBIT \CLICLA\
SIXBIT \USRDIS\
SIXBIT \JOBBOJ\ ;THIS STUFF GROWS
SIXBIT \OJBNET\ ; INCREASINGLY USELESS...
SIXBIT \PTPPTR\
SIXBIT \ERRSPY\
SIXBIT \COR \ ;" " => END OF LIST
] ;END OF IFN ITS
SUBTTL CONVERSION: SIXBIT => NAMELIST
;;; THIS ROUTINE TAKES FOUR WORDS OF SIXBIT ON THE FIXNUM
;;; PDL AND, POPPING THEM, RETURNS THE EQUIVALENT NAMELIST.
;;; ZERO WORDS BECOME *'S.
;;; NAMELIST FUNCTION MERELY CONVERTS ARG TO SIXBIT,
;;; THEN BACK TO NAMELIST FORM.
NAMELIST: PUSHJ P,FIL6BT ;SUBR 1
6BTNML: JSP T,QIOSAV ;MUST ALSO PRESERVE F
10$ HLLZS (FXP) ;DEC-10 FNAME2 IS 3 CHARS
PUSHJ P,6BTNL1 ;CONVERT FILE NAMES
PUSH P,A
10% PUSHJ P,6BTNL1 ;CONVERT DEVICE/SNAME
IFN D10,[
HLRZ TT,(FXP) ;FOR DEC-10, CONS UP PPN
JSP T,FXCONS
MOVEI B,(A)
POP FXP,TT
TLZ TT,-1
JSP T,FXCONS
PUSHJ P,ACONS
PUSHJ P,XCONS
PUSH P,A
POP FXP,TT ;NOW GET DEVICE NAME
PUSHJ P,SIXATM
PUSHJ P,6BTNL2 ;CONS TOGETHER
] ;END OF IFN D10
6BTNL2: POP P,B
JRST CONS
6BTNL1: POP FXP,TT ;MAKE LIST OF TWO NAMES
PUSHJ P,SIXATM
PUSHJ P,NCONS
PUSH P,A
POP FXP,TT
PUSHJ P,SIXATM
JRST 6BTNL2
SIXATM: SETOM LPNF ;TAKE SIXBIT IN TT, MAKE
MOVE C,PNBP ; ATOMIC SYMBOL. EMBEDDED
MOVSI T,(ASCII \*\) ; BLANKS COUNT, TRAILING DON'T.
MOVEM T,PNBUF ;ZERO WORD BECOMES *.
SETZM PNBUF+1
SIXAT1: JUMPE TT,RINTERN
SETZ T,
LSHC T,6
ADDI T,40
IDPB T,C
JRST SIXAT1
SUBTTL CONVERSION: SIXBIT => NAMESTRING
;;; THIS ROUTINE TAKES FOUR WORDS OF FILE SPECS ON THE FIXNUM
;;; PDL AND GENERATES AN UNINTERNED ATOMIC SYMBOL WHOSE
;;; PRINT NAME IS THE EXTERNAL FORM OF FILE SPECIFICATION.
;;; ZERO WORDS BECOME *'S.
;;; THE NAMESTRING AND SHORTNAMESTRING MERELY CONVERT THEIR
;;; ARGUMENTS TO SIXBIT AND THEN INTO NAMESTRING FORM.
SHORTNAMESTRING: HRROS (P) ;SUBR 1
NAMESTRING: PUSHJ P,FIL6BT ;SUBR 1
6BTNMS: SETOM LPNF ;WILL FIT IN PNBUF
MOVEI R,↑Q
MOVE C,PNBP
MOVE D,(P)
TLNE D,1 ;SKIP UNLESS SHORTNAMESTRING
JRST 6BTNS0
MOVE TT,-3(FXP) ;PUSH OUT DEVICE
MOVEI D,":
PUSHJ P,6BTNS1
10% MOVE TT,-2(FXP) ;PUSH OUT SNAME FOR ITS
10% MOVEI D,";
10% PUSHJ P,6BTNS1
6BTNS0: MOVE TT,-1(FXP) ;PUSH OUT FILE NAMES
10% MOVEI D,40 ; "FOOBAR QUUXLY" FOR ITS
10$ MOVEI D,". ; "FOOBAR.QUX" FOR DEC-10
PUSHJ P,6BTNS1
10% MOVE TT,(FXP)
10$ HLLZ TT,(FXP)
SETZ D,
PUSHJ P,6BTNS1
IFN D10,[
MOVE D,(P)
TLNE D,1 ;SKIP UNLESS SHORTNAMESTRING
JRST 6BTNS8
MOVEI D,133 ;HACK DEC-10 PPN IN FORM
IDPB D,C ; "[0123,4567]"
HLRZ TT,-2(FXP)
PUSHJ P,6BTNS5
MOVEI D,",
IDPB D,C
HRRZ TT,-2(FXP)
PUSHJ P,6BTNS5
MOVEI D,135
IDPB D,C
] ;END OF IFN D10
6BTNS8: TLNN C,760000
JRST 6BTNS9
IDPB D,C
JRST 6BTNS8
6BTNS9: SUB FXP,R70+4
JRST PNGNK2
6BTNS1: SKIPN TT ;PUSH OUT ONE FILE NAME
MOVEI TT,(SIXBIT \*\)
6BTNS2: SETZ T,
LSHC T,6
JUMPE T,6BTNS3
10$ CAIE T,133-40 ;FOR DEC-10, BRACKETS MUST
10$ CAIN T,135-40 ; BE QUOTED
10$ JRST 6BTNS3
CAIE T,':
10% CAIN T,';
10$ CAIN T,'.
6BTNS3: IDPB R,C ;↑Q TO QUOTE FUNNY CHARS
ADDI T,40
IDPB T,C
JUMPN TT,6BTNS2
SKIPE D
IDPB D,C
POPJ P,
IFN D10,[
6BTNS5: LSHC TT,-3 ;OUTPUT HALF A PPN IN
LSH D,-41 ; ZERO-SUPPRESSED OCTAL
ADDI D,"0
HRLM D,(P)
SKIPE TT
PUSHJ P,6BTNS5
HLRZ D,(P)
IDPB D,C
POPJ P,
] ;END OF IFN D10
SUBTTL CONVERSION: NAMESTRING => SIXBIT
;;; THIS ONE IS PRETTY HAIRY. IT CONVERTS AN ATOMIC
;;; SYMBOL IN A, REPRESENTING A FILE SPECIFICATION,
;;; INTO FOUR WORDS WHICH ARE LEFT ON THE FIXNUM PDL.
;;; SPACE AND ALL CONTROL CHARACTERS BREAK FILE NAMES,
;;; EXCEPT ↑Q WHICH QUOTES SPACE, ":", AND ";".
;;; FOR DEC-10, ↑Q QUOTES ".", "[", AND "]" AS WELL.
;;; LOWER CASE (ASCII > 140) IS CONVERTED TO UPPER CASE.
NMS6B0: WTA [INCOMPREHENSIBLE NAMESTRING!]
NMS6BT: JSP T,0PUSH-5 ;WORKING ROOM
MOVEI AR1,(FXP) ;AR1 POINT TO WORDS OVER PRINTA
HRLI AR1,440600
HRROI R,NMS6B1
PUSH P,A
PUSHJ P,PRINTA ;EXPLODEC THE ATOM
MOVEI A,40
PUSHJ P,(R) ;MAYBE FINISH OFF LAST NAME
POP P,A
AOJE AR1,NMS6B0
SUB FXP,R70+1
MOVSI T,(SIXBIT \*\) ;UNSPECIFIED COMPONENTS BECOME *
REPEAT 4,[
SKIPN -.RPCNT(FXP)
MOVEM T,-.RPCNT(FXP)
] ;END OF REPEAT 4
POPJ P,
NMS6B1: CAMN AR1,XC-1 ;IF ERROR ENCOUNTERED,
POPJ P, ; IGNORE REST OF NAMESTRING
CAIE A,↑Q
JRST NMS6B2
TLCN AR1,1 ;BIT 3.1 OF AR1 IS ↑Q FLAG
POPJ P, ;↑Q↑Q IS A FILE NAME BREAK
NMS6B2: CAIL A,40
JRST NMS6B7
NMS6B8: SKIPN D,(AR1) ;IF NO FILE NAME YET, IGNORE
JRST NMS6B6
SKIPN -2(AR1) ;FIGURE OUT WHERE TO PUT THIS NAME
JSP AR2A,NMS6B5 ;FILE NAME 1 GETS FIRST CHOICE,
SKIPN -1(AR1) ; THEN FILE NAME 2
JSP AR2A,NMS6B5
SKIPN -4(AR1) ;NOW TRY DEVICE NAME
NMS6B3: JSP AR2A,NMS6B5
SKIPN -3(AR1) ;SNAME IS LAST HOPE
NMS6B4: JSP AR2A,NMS6B5
NMS6BL: SETO AR1, ;UGH BLETCH CHOKE
POPJ P,
NMS6B5: MOVEM D,@-2(AR2A)
SETZM (AR1)
NMS6B6: HRLI AR1,440600 ;RESET BYTE POINTER
POPJ P,
NMS6B7: TLZE AR1,1 ;SIXBIT CHAR FOUND
JRST NMS6B9 ;IF QUOTED, TAKE AS IS
CAIN A,40
JRST NMS6B8 ;SPACE IS NAME BREAK
CAIE A,":
CAIN A,";
JRST NMS6BZ
NMS6B9: CAIGE A,140 ;LOWER CASE => UPPER
SUBI A,40 ;CONVERT TO SIXBIT
TLNE AR1,770000
IDPB A,AR1
POPJ P,
NMS6BZ: SKIPN D,(AR1) ;ANYTHING THERE?
JRST NMS6BL
CAIN A,":
JRST NMS6BC ;":" => DEVICE NAME
SKIPN -3(AR1) ;";" => SNAME
JSP AR2A,NMS6B5
JRST NMS6BL
NMS6BC: SKIPN -4(AR1)
JSP AR2A,NMS6B5
JRST NMS6BL
SUBTTL CONVERSION: ANY FILE SPEC => SIXBIT
;;; TAKE ARGUMENT IN A (MAY BE FILE ARRAY, NAMELIST,
;;; OR NAMESTRING), FIGURE IT OUT AND SOMEHOW RETURN
;;; FOUR WORDS OF FILE SPECS ON THE FIXNUM PDL.
;;; IFL6BT SAYS THAT T MEANS TTY INPUT, NOT TTY OUTPUT.
;;; SAVES C AR1 AR2A
IFL6BT: CAIN A,TRUTH
HRRZ A,V%TYI
JRST FIL6B0
FIL6BT: CAIN A,TRUTH
HRRZ A,V%TYO
FIL6B0: SKIPN A ;NIL => DEFAULTS
HRRZ A,VDEFAULTF
FIL6B1: MOVEI R,(A)
LSH R,-SEGLOG
SKIPGE R,ST(R)
JRST NML6BT ;LIST => NAMELIST
TLNN R,SA
JRST FIL6B2 ;NOT ARRAY => NAMESTRING
MOVE R,ASAR(A)
TLNN R,AS<JOB+FIL>
JRST NMS6B0 ;INCOMPREHENSIBLE NAMESTRING
MOVEI TT,F.DEV ;GET FILE SPECS FROM ARRAY
PUSH FXP,@TTSAR(A)
10% MOVEI TT,F.SNM
10$ MOVEI TT,F.PPN
PUSH FXP,@TTSAR(A)
MOVEI TT,F.FN1
PUSH FXP,@TTSAR(A)
MOVEI TT,F.FN2
PUSH FXP,@TTSAR(A)
POPJ P,
FIL6B2: JSP T,QIOSAV
JRST NMS6BT
QIOSAV: SAVE B C AR1 AR2A
PUSHJ P,(T)
RSTR AR2A AR1 C B
POPJ P,
SUBTTL MERGING ROUTINES, MERGEF, TRUENAME, PROBEF
;;; MERGEF TAKES TWO FILE SPECS OF ANY KIND, MERGES THEM,
;;; AND RETURNS A NAMELIST OF THE RESULTING SPECS.
;;; AS A CROCK, (MERGEF X '*) SIMPLY MAKES THE SECOND
;;; FILE NAME BE *.
MERGEF: PUSH P,B
PUSHJ P,FIL6BT
POP P,A
CAIE A,Q.
JRST MRGF1
MOVSI T,(SIXBIT \*\)
MOVEM T,(FXP)
JRST 6BTNML
MRGF1: PUSHJ P,FIL6BT
PUSHJ P,IMRGF
JRST 6BTNML
;;; IMRGF MERGES TWO SETS OF SPECS ON THE FIXNUM PDL.
;;; DMRGF MERGES A SET WITH THE DEFAULT FILE NAMES.
;;; DEC-10 PPN'S MERGE HALVES OF THE PPN SEPARATELY;
;;; AN UNSPECIFIED HALF IS ZERO, *NOT* (SIXBIT \*\)!!
;;; SAVES F (SEE LOAD).
DMRGF: PUSH FLP,F ;MERGE WITH DEFAULT FILE NAMES
HRRZ A,VDEFAULTF
PUSHJ P,FIL6BT
POP FLP,F
IMRGF: MOVEI T,4 ;MERGE TWO SETS OF NAMES ON FXP
MOVSI TT,(SIXBIT \*\)
MRGF2:
10$ MOVE R,D
POP FXP,D
SKIPE -3(FXP)
CAMN TT,-3(FXP)
MOVEM D,-3(FXP)
SOJG T,MRGF2
10$ MOVE D,-2(FXP) ;R HAS PPN 2 - GET PPN 1 IN D
10$ TLNN D,-1 ;DEFAULT EACH HALF SEPARATELY
10$ HLLM R,-2(FXP)
10$ TRNN D,-1
10$ HRRM R,-2(D)
POPJ P,
;;; (TRUENAME <FILE>) RETURNS THE RESULT OF .RCHST ON ITS,
;;; I.E. THE REAL FILE NAMES AFTER TRANSLATIONS, LINKS, ETC.
;;; THE RESULT IS A NAMELIST.
TRUENAME:
CAIN A,TRUTH ;SUBR 1
HRRZ A,V%TYO
EXCH AR1,A
PUSHJ P,FILOK
EXCH AR1,A
POP FXP,T ;BEWARE! FILOK DID A LOCKI!
REPEAT 4, PUSH FXP,F.RDEV+.RPCNT(TT)
PUSH FXP,T
UNLOCKI
JRST 6BTNML
;;; (STATUS UREAD)
SUREAD: SKIPN A,VUREAD
POPJ P,
PUSHJ P,TRUENAME
HLRZ B,(A)
HRRZ A,(A)
HRRZ C,(A)
HRRM B,(C)
POPJ P,
;;; (STATUS UWRITE)
SUWRITE: SKIPE A,VUWRITE
PUSHJ P,TRUENAME
JRST $CAR ;(CAR NIL) => NIL
;;; ROUTINE TO SET UP ARGS FOR TWO-ARGUMENT FILE FUNCTION.
;;; PUT TWO SETS OF FILE NAMES ON FXP. IF THE ARGS ARE
;;; X AND Y, THEN THE NAME ON FXP ARE (MERGEF X NIL) AND
;;; (MERGEF Y (MERGEF X NIL)). THE FIRST ARG IS LEFT IN AR1.
2MERGE: PUSH P,A
PUSH P,B
PUSHJ P,FIL6BT
PUSHJ P,DMRGF
POP P,A
PUSHJ P,FIL6BT
REPEAT 4, PUSH FXP,-7(FXP)
PUSHJ P,IMRGF ;NOW WE HAVE THE MERGED FILE SPECS
POP P,AR1 ;FIRST ARG
POPJ P,
;;; (PROBEF X) TRIES TO DECIDE WHETHER FILE X EXISTS.
;;; CURRENTLY THIS IS DONE BY TRYING TO OPEN THE FILE.
;;; RETURNS REAL FILE NAMES ON SUCCESS, NIL ON FAILURE.
PROBEF: PUSHJ P,FIL6BT ;SUBR 1
PROBF0: PUSHJ P,DMRGF
.CALL PROBF8
JRST PROBF6
.CALL PROBF9
.VALUE
.CLOSE TMPC,
JRST 6BTNML
PROBF6: SUB FXP,R70+4
JRST FALSE
PROBF8: SETZ
SIXBIT \OPEN\ ;OPEN FILE (ASCII UNIT INPUT)
1000,,TMPC ;CHANNEL #
,,-3(FXP) ;DEVICE NAME
,,-1(FXP) ;FILE NAME 1
,,0(FXP) ;FILE NAME 2
400000,,-2(FXP) ;SNAME
PROBF9: SETZ
SIXBIT \RFNAME\ ;READ REAL FILE NAMES
1000,,TMPC ;CHANNEL #
2000,,-3(FXP) ;DEVICE NAME
2000,,-1(FXP) ;FILE NAME 1
2000,,0(FXP) ;FILE NAME 2
402000,,-2(FXP) ;SNAME
SUBTTL RENAME FUNCTION
;;; (RENAME X Y) RENAMES (MERGEF X (NAMELIST NIL)) TO BE
;;; (MERGEF Y (MERGEF X (NAMELIST NIL))). MUST BE CAREFUL
;;; IF X IS AN OUTPUT FILE ARRAY - MUST USE A RENAME-WHILE-OPEN.
$RENAME: PUSHJ P,2MERGE
JSP TT,XFILEP ;SKIP IF FILE ARRAY
JRST RENAM2
MOVE TT,TTSAR(AR1)
TLNE TT,TTS<CL>
JRST RENAM2
MOVEI TT,F.CHAN ;OPEN OUTPUT FILE
HLLOS NOQUIT
.CALL RENAM7 ;MUST RENAME WHILE OPEN
IOJRST 0,RENAM6
MOVE TT,TTSAR(AR1)
MOVE T,-1(FXP) ;UPDATE THE FILE NAMES
MOVEM T,F.FN1(TT)
MOVE T,(FXP)
MOVEM T,F.FN2(TT)
.CALL RFNAME ;READ BACK THE TRUENAMES
.VALUE
PUSHJ P,CZECHI
SUB FXP,R70+4
MOVEI A,(AR1)
RENAM1: SUB FXP,R70+4 ; WITH NEW NAMES
POPJ P,
RENAM2: POP P,AR1
.CALL RENAM8 ;ORDINARY RENAME
IOJRST 0,RENAM9
RENAM3: PUSHJ P,6BTNML ;RETURN VALUE IS NAMELIST
JRST RENAM1
RENAM7: SETZ
SIXBIT \RENMWO\ ;RENAME WHILE OPEN
,,@TTSAR(AR1) ;CHANNEL #
,,-1(FXP) ;NEW FILE NAME 1
400000,,(FXP) ;NEW FILE NAME 2
RENAM8: SETZ
SIXBIT \RENAME\ ;RENAME
,,-7(FXP) ;DEVICE NAME
,,-5(FXP) ;OLD FILE NAME 1
,,-4(FXP) ;OLD FILE NAME 2
,,-6(FXP) ;SNAME
,,-1(FXP) ;NEW FILE NAME 1
400000,,(FXP) ;NEW FILE NAME 2
RENAM6: PUSHJ P,CZECHI
RENAM9: MOVEI A,Q$RENAME
RENAM5: PUSH P,A ;ERROR MESSAGE IN C
PUSHJ P,6BTNML
PUSHJ P,NCONS
PUSH P,A
PUSHJ P,6BTNML
POP P,B
PUSHJ P,CONS
POP P,B
XCIOL: PUSHJ P,XCONS ;XCONS, THEN IOL
%IOL (C)
RFNAME: SETZ
SIXBIT \RFNAME\ ;READ FILE NAMES
,,F.CHAN(TT) ;CHANNEL #
2000,,F.RDEV(TT) ;DEVICE NAME
2000,,F.RFN1(TT) ;FILE NAME 1
2000,,F.RFN2(TT) ;FILE NAME 2
402000,,F.RSNM(TT) ;SNAME
SUBTTL DELETEF AND CLOSE FUNCTIONS
;;; (DELETEF X) DELETES THE FILE X. (THAT SOUNDS LOGICAL...)
$DELETEF: PUSHJ P,FIL6BT ;SUBR 1
PUSHJ P,DMRGF ;MERGE ARG WITH DEFAULTS
.CALL $DEL7
IOJRST 0,$DEL9
JRST 6BTNML
$DEL7: SETZ
SIXBIT \DELETE\ ;DELETE FILE
,,-3(FXP) ;DEVICE NAME
,,-1(FXP) ;FILE NAME 1
,,0(FXP) ;FILE NAME 2
400000,,-2(FXP) ;SNAME
$DEL9: PUSHJ P,6BTNML
PUSHJ P,ACONS
MOVEI B,Q$DELETEF
JRST XCIOL
;;; (CLOSE X) CLOSES THE FILE ARRAY X. THE ARRAY ITSELF
;;; IS *NOT* FLUSHED - MAY WANT TO RE-OPEN IT.
CLOSE0: WTA [NOT FILE - CLOSE!]
$CLOSE: SKOTT A,SA
JRST CLOSE0
MOVE TT,ASAR(A)
TLNN TT,AS.FIL
JRST CLOSE0
ICLOSE: HLLOS NOQUIT
MOVE TT,TTSAR(A)
TLNE TT,TTS<CL> ;SKIP UNLESS ALREADY CLOSED
JRA A,CZECHI ;CROCK TO PUT NIL IN A AND JRST
TLNE TT,TTS<IO> ;SKIP UNLESS OUTPUT FILE ARRAY
PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER
MOVE TT,TTSAR(A)
TLNE TT,TTS<TY>
SKIPN T,FT.CNS(TT)
JRST CLOSE4
SETZM FT.CNS(TT) ;UNLINK TWO TTY'S WHICH
MOVE T,TTSAR(T) ; WERE TTYCONS'D TOGETHER
SETZM FT.CNS(T) ; IF ONE IS CLOSED
CLOSE4: HRRZ T,F.CHAN(TT)
MOVSI D,TTS<CL> ;TURN ON "FILE CLOSED"
IORM D,TTSAR(A) ; BIT IN ARRAY SAR
SETZM CHNTB(T) ;CLEAR CHANNEL TABLE ENTRY
.CALL CLOSE9 ;CLOSE FILE
.VALUE
MOVEI A,TRUTH
JRST CZECHI
CLOSE9: SETZ
SIXBIT \CLOSE\ ;CLOSE CHANNEL
401000,,(T) ;CHANNEL #
SUBTTL FORCE-OUTPUT
;;; (FORCE-OUTPUT X) FORCES THE OUTPUT BUFFER OF OUTPUT FILE ARRAY X.
FORCE: PUSH P,AR1
MOVEI AR1,(A)
PUSHJ P,FORCE1
POP P,AR1
POPJ P,
FORCE1: PUSHJ P,OFILOK ;DOES A LOCKI
PUSHJ P,IFORCE
JRST UNLKTRUE
;;; INTERNAL OUTPUT BUFFER FORCE ROUTINE. EXPECTS USER
;;; INTERRUPTS OFF, AND FILE ARRAY TTSAR IN TT.
;;; CLOBBERS T, TT, D, AND F.
IFORCE: TLNE TT,TTS<CL>
LERR [SIXBIT \CAN'T FORCE OUTPUT ON CLOSED FILE!\]
SKIPGE F,F.MODE(TT) .SEE FBT.CM ;CAN'T FORCE A CHARMODE FILE
POPJ P,
TLNE TT,TTS<BN>
JRST FORCE4
TLNE F,FBT.SI
JRST FORCE7
MOVE D,AB.BP(TT) ;PAD ASCII BLOCK FILES WITH ↑C'S
SKIPA T,R70+↑C
FORCE2: IDPB T,D
MOVE F,D ;THIS PIECE OF HAIR WORKS
IBP F ; FOR ANY BYTE SIZE, UNLIKE TE
TLZ F,-1 ; USUAL TLNN 760000 HACK
CAIN F,(D)
JRST FORCE2
MOVEI T,FB.BUF-1(TT) ;CALCULATE # OF WORDS TO OUTPUT
FORCE3: SUB T,AB.BP(TT) .SEE XB.AOB
HRREI F,(T)
MOVN F,F
MOVSI T,(T)
HRRI T,FB.BUF(TT)
.CALL IOTTTT ;OUTPUT THEM, ALREADY
.VALUE
TLNE TT,TTS<BN>
JRST FORCE5
JSP D,FORCE6 ;RESET BUFFER PARAMETERS
SKIPGE F.FPOS(TT) ;THAT'S ALL IF NOT RANDOM ACCESS
POPJ P,
ADDB F,F.FPOS(TT) ;UPDATE ACCESS COUNTER
MOVE D,T ;WAS ANY PADDING USED?
IBP D
TLZ D,-1
CAIE D,(T)
POPJ P,
SUB F,FB.BFL(TT) ;IF SO, JUGGLE BUFFER SO THAT
.CALL ACCESS ; WORD WITH PADDING WILL BE
.VALUE ; REWRITTEN FOR NEXT IOT WITH
MOVE D,(T) ; NEW CHARS INSTEAD OF ↑C'S
MOVEM D,FB.BUF(TT)
HLLM T,AB.BP(TT)
POPJ P,
FORCE4: MOVEI T,FB.BUF(TT)
JRST FORCE3
FORCE5: MOVE T,FB.IOT(TT) ;FOR BINARY FILE, UPDATE
MOVEM T,XB.AOB(TT) ; AOBJN POINTER
SKIPL F.FPOS(TT) ;IF RANDOM ACCESS,
ADDM F,F.FPOS(TT) ; UPDATE ACCESS COUNT
POPJ P,
FORCE6: MOVE T,FB.BFL(TT) ;RESET COUNTER FOR ASCII FILE
IMULI T,@FB.BYT(TT)
MOVEM T,AB.CNT(TT)
MOVEI T,FB.BUF-1(TT) ;RESET BYTE POINTER
HLL T,FB.BYT(TT)
EXCH T,AB.BP(TT) ;LEAVE OLD BYTE POINTER IN T
JRST (D)
FORCE7: MOVE F,FB.BFL(TT) ;FOR FILES WHICH USE SIOT
IMULI F,@FB.BYT(TT)
SUB F,AB.CNT(TT)
MOVE D,F
HRRI T,FB.BUF-1(TT)
HLL T,FB.BYT(TT)
.CALL SIOT
.VALUE
SKIPL F.FPOS(TT)
ADDM F,F.FPOS(TT)
JSP D,FORCE6
POPJ P,
IOTTTT: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
400000,,T ;DATA POINTER (DATA?)
SIOT: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
,,T ;BYTE POINTER
400000,,D ;BYTE COUNT
SUBTTL STATUS FILEMODE
;;; (STATUS FILEMODE <FILE> ) RETURNS A LIST DESCRIBING
;;; THE FILE: NIL ==> FILE HAS BEEN CLOSED; OTHERWISE
;;; THE CAR OF THIS LIST IS A VALID OPTIONS
;;; LIST FOR THE OPEN FUNCTION. THE CDR OF THIS LIST
;;; CONTAINS INFORMATIVE ITEMS WHICH ARE NOT NECESSARILY
;;; USER-SETTABLE FEATURES ABOT THE FILE.
;;; NON-FILE ARGUMENT CAUSES AN ERROR.
;;; PRESENTLY SUCH GOODIES INCLUDE:
;;; RUBOUT AN OUTPUT TTY THAT CAN SELECTIVELY ERASE
;;; CURSORPOS AN OUTPUT TTY THAT CAN CURSORPOS WELL
;;; SAIL FOR AN OUTPUT TTY, HAS SAIL CHARACTER SET
;;; FILEPOS CAN FILEPOS CORRECTLY (RANDOM ACCESS)
SFMD0: %WTA NFILE
SFILEMODE:
JSP TT,AFILEP
JRST SFMD0
LOCKI
MOVE TT,TTSAR(A)
TLNE TT,TTS<CL>
JRST UNLKFALSE
MOVE R,F.FPOS(TT)
MOVEI A,QBLOCK
SKIPGE F,F.MODE(TT) .SEE FBT.CM
MOVEI A,QSINGLE
UNLOCKI
PUSHJ P,NCONS
MOVEI B,QDSK
TLNE TT,TTS<TY>
MOVEI B,QTTY
PUSHJ P,XCONS
MOVEI B,Q$ASCII
TLNE TT,TTS<IM>
MOVEI B,QIMAGE
TLNN TT,TTS<IO>
TLNN TT,TTS<TY>
JRST SFMD1
TLNE F,FBT<FU>
SFMD1: TLNE TT,TTS<BN>
MOVEI B,QFIXNUM
PUSHJ P,XCONS
MOVEI B,Q$IN
TLNE TT,TTS<IO>
MOVEI B,Q$OUT
TLNE F,FBT<AP>
MOVEI B,QAPPEND
PUSHJ P,XCONS
MOVEI B,QECHO
TLNE F,FBT<EC>
PUSHJ P,XCONS
MOVEI C,(A)
SETZ A,
MOVEI B,QSAIL
TLNE F,FBT<SA>
PUSHJ P,XCONS
MOVEI B,QRUBOUT
TLNE F,FBT<SE>
PUSHJ P,XCONS
MOVEI B,QCURSORPOS
TLNE F,FBT<CP>
PUSHJ P,XCONS
MOVEI B,QFILEPOS
TLNE TT,TTS<IO> ;OUTPUT FILEPOS NOT IMPLEMENTED
SETO R,
SKIPL R
PUSHJ P,XCONS
MOVEI B,(C)
JRST XCONS
SUBTTL LOAD FUNCTION
;;; (LOAD FOO) LOADS THE FILE FOO. IT FIRST PROBEF'S TO
;;; ASCERTAIN THE EXISTENCE OF THE FILE, AND CHECKS THE FIRST
;;; WORD TO SEE WHETHER IT IS AN ASCII OR FASL FILE.
;;; IF NO SECOND FILE NAME IS GIVEN, "FASL" IS TRIED FIRST,
;;; AND THEN ">" IF NO FASL FILE EXISTS.
;;; IF A FASL FILE, IT GIVES THE FILE NAMES TO FASLOAD.
;;; IF AN ASCII FILE, IT IS OPENED, (INFILE ↑Q, *, +, -, INSTACK)
;;; BOUND TO (<THE FILE>, T, *, +, -, NIL), AND A READ-EVAL
;;; LOOP PERFORMED UNTIL END OF FILE OCCURS LEAVING INSTACK=NIL
;;; AND INFILE=T.
LOAD: PUSHJ P,FIL6BT ;SUBR 1
MOVE F,(FXP)
PUSHJ P,DMRGF ;DMRGF SAVES F
LOCKI
TLC F,(SIXBIT \*\)
JUMPN F,LOAD3
MOVE TT,[SIXBIT \FASL\]
MOVEM TT,-1(FXP)
JSP T,FASLP1
JRST LOAD1 ;FILE NOT FOUND
JRST LOAD2 ;FASL FILE
LOAD5: UNLOCKI ;EXPR FILE FOUND
PUSHJ P,6BTNML
PUSH P,[LOAD6]
PUSH P,A
MOVNI T,1
JRST $OPEN ;OPEN AS A FILE OBJECT
LOAD6: HRRZ B,VIPLUS ;WE WANT +, -, * TO WORK AS FOR TOP LEVEL,
HRRZ C,V. ; BUT NOT SCREW THE OUTSIDE WORLD
HRRZ AR1,VIDIFFERENCE
MOVEI AR2A,TRUTH
JSP T,SPECBIND
0 A,VINFILE
0 B,VIPLUS
0 C,V.
0 AR1,VIDIFFERENCE
0 AR2A,TAPRED
VINSTACK
JRST LOAD7A
LOAD7: PUSHJ P,LISP1A ;USE THE EVAL PART OF THE TOP LEVEL
HRRZM A,V.
LOAD7A:
REPEAT 2, PUSH P,[LOAD8] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
LOAD8: CAIE A,LOAD8
JRST LOAD7
HRRZ B,VINFILE
SKIPN VINSTACK
CAIE B,TRUTH
JRST LOAD7A
PUSHJ P,UNBIND
JRST TRUE
LOAD1: MOVEI A,QLOAD
JUMPN F,LOAD4 ;IF SECOND FILE NAME WAS GIVEN, WE HAVE LOST
MOVSI TT,(SIXBIT \>\) ;OTHERWISE TRY ">"
MOVEM TT,-1(FXP)
LOAD3: JSP T,FASLP1
JRST LOAD4 ;LOSE COMPLETELY
JRST LOAD2 ;FASL FILE
JRST LOAD5 ;EXPR CODE
LOAD2: UNLOCKI ;FASL FILE - GO FASLOAD IT
PUSHJ P,6BTNML
JRST FASLOAD
.CALL FASLP9 ;PURELY TO FAKE OUT IOJRST
LOAD4: IOJRST 0,.+1
PUSH P,A
UNLOCKI
PUSHJ P,6BTNML ;LOSEY LOSEY
PUSHJ P,NCONS
POP P,B
JRST XCIOL
IFN QIO,[
;;; (FASLP <FILE>) TELLS WHETHER THE FILE IS A FASL FILE.
;;; ERROR IF FILE DOES NOT EXIST.
$FASLP: PUSHJ P,FIL6BT
PUSHJ P,DMRGF
MOVE A,Q$FASLP
LOCKI
JSP T,FASLP1
JRST LOAD4
SKIPA A,[TRUTH]
MOVEI A,NIL
UNLOCKI
SUB FXP,R70+4
POPJ P,
;;; ROUTINE TO TEST A FILE FOR FASL-NESS.
;;; JSP T,FASLP1
;;; JRST NOTFOUND ;FILE NOT FOUND, OR OTHER ERROR
;;; JRST FASL ;FILE IS A FASL FILE
;;; ... ;FILE IS NOT A FASL FILE
;;; FXP MUST HOLD THE FOUR FILE NAMES, WITH A LOCKI WORD ABOVE THEM.
FASLP1: .CALL FASLP9
JRST (T)
.IOT TMPC,TT
.CLOSE TMPC,
TRZ TT,1
CAMN TT,[SIXBIT \*FASL*\]
JRST 1(T)
JRST 2(T)
FASLP9: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,4 ;IMAGE UNIT INPUT
1000,,TMPC ;CHANNEL NUMBER
,,-4(FXP) ;DEVICE NAME
,,-2(FXP) ;FILE NAME 1
,,-1(FXP) ;FILE NAME 2
400000,,-3(FXP) ;SNAME
] ;END OF IFN QIO
SUBTTL OPEN FUNCTION
;;; (OPEN <FILE> <MODELIST>) OPENS A FILE AND RETURNS A
;;; CORRESPONDING FILE OBJECT. IT IS ACTUALLY AN LSUBR
;;; OF ZERO TO TWO ARGUMENTS. THE <FILE> DEFAULTS TO THE
;;; CURRENT DEFAULT FILE NAMES. THE <MODELIST> DEFAULTS
;;; TO NIL.
;;; IF <FILE> IS A NAMELIST OR NAMESTRING, A NEW FILE ARRAY
;;; IS CREATED. IF <FILE> IS A FILE ARRAY ALREADY, IT IS
;;; CLOSED AND RE-OPENED IN THE SPECIFIED MODE; ITS FORMER
;;; MODES SERVE AS THE DEFAULTS FOR THE <MODELIST>.
;;; THE <MODELIST> DETERMINES A LARGE NUMBER OF ATTRIBUTES
;;; FOR OPENING THE FILE. FOR EACH ATTRIBUTE THERE ARE
;;; TWO OR MORE MUTUALLY EXCLUSIVE VALUES WHICH MAY BE
;;; SPECIFIED AS FOLLOWS. VALUES MARKED BY A * ARE THOSE
;;; USED AS DEFAULTS WHEN THE <FILE> IS A NAMELIST OR
;;; NAMESTRING. IF THE <MODELIST> IS AN ATOM, IT IS THE
;;; SAME AS SPECIFYING THE LIST OF THAT ONE ATOM.
;;; DIRECTION:
;;; * IN INPUT FILE
;;; * READ SAME AS "IN"
;;; OUT OUTPUT FILE
;;; PRINT SAME AS "OUT"
;;; APPEND OUTPUT, APPENDED TO EXISTING FILE
;;; DATA MODE:
;;; * ASCII FILE IS A STREAM OF ASCII CHARACTERS.
;;; SYSTEM-DEPENDENT TRANSFORMATIONS MAY
;;; OCCUR, SUCH AS SUPPLYING LF AFTER CR,
;;; OR BEING CAREFUL WITH OUTPUT OF ↑P,
;;; OR MULTICS ESCAPE CONVENTIONS.
;;; FIXNUM FILE IS A STREAM OF FIXNUMS. THIS
;;; IS FOR DEALING WITH FILES THOUGHT OF
;;; AS "BINARY" RATHER THAN "CHARACTER".
;;; IMAGE FILE IS A STREAM OF ASCII CHARACTERS.
;;; ABSOLUTELY NO TRANSFORMATIONS ARE MADE.
;;; DEVICE TYPE:
;;; * DSK STANDARD KIND OF FILE.
;;; CLA LIKE DSK, BUT REQUIRES BLOCK MODE, AND
;;; GOBBLES THE FIRST TWO WORDS, INSTALLING
;;; THEM IN THE TRUENAME. USEFUL IN CLI-MESSAGE
;;; INTERRUPT FUNCTION.
;;; TTY CONSOLE. IN PARTICULAR, ONLY TTY INPUT
;;; FILES HAVE INTERRUPT CHARACTER FUNCTIONS
;;; ASSOCIATED WITH THEM.
;;; BUFFERING MODE:
;;; * BLOCK DATA IS BUFFERED.
;;; SINGLE DATA IS UNBUFFERED.
;;; PRINTING AREA:
;;; ECHO OPEN TTY IN ECHO AREA (ITS ONLY)
;;; SOME OF THESE VALUES ARE OF COURSE SYSTEM-DEPENDENT.
;;; YOUR LOCAL LISP SYSTEM WILL ATTEMPT TO DO THE RIGHT THING,
;;; HOWEVER, IN ANY CASE.
;;; IF THE OPTIONS LIST IS INVALID IN ANY WAY, OPEN MAY EITHER
;;; GIVE A WRNG-TYPE-ARGS ERROR, OR BLITHELY ASSUME A CORRECTED
;;; VALUE FOR AN ATTRIBUTE. IN GENERAL, ERRORS SHOULD OCCUR
;;; ONLY FOR TRULY CONFLICTING SPECIFICATIONS. ON THE OTHER
;;; HAND, SPECIFYING BLOCK MODE FOR A DEVICE THAT THE SYSTEM
;;; WANTS TO HANDLE ONLY IN CHARACTER MODE SHOULD JUST GO AHEAD
;;; AND USE CHARACTER MODE.
INCLUDE: HLRZ A,(A) ;FSUBR
PUSH P,[INPUSH] ;(DEFUN INCLUDE FEXPR (X)
PUSH P,A ; (INPUSH (OPEN (CAR X))))
MOVNI T,1
$OPEN: MOVEI D,Q$OPEN ;LSUBR (0 . 2)
CAMGE T,XC-2
JRST WNALOSE
SETZB A,B
CAMN T,XC-2
POP P,B
SKIPE T
POP P,A
OPEN0J: PUSH P,T ;SAVE NUMBER OF ARGS ON P (NOT FXP!)
SETZB D,F
JSP TT,AFILEP
JRST OPEN1A
MOVEI TT,F.MODE
MOVE F,@TTSAR(A)
SKIPE B
TLZ F,FBT<EC> ;MAKE CHUCK RICH HAPPY
OPEN1A: JUMPE B,OPEN1Y
MOVEI C,(B)
MOVEI TT,(B)
LSH TT,-SEGLOG
SKIPG ST(TT)
JRST OPEN1C
MOVSI AR2A,(B)
MOVEI C,AR2A
OPEN1C: JUMPE C,OPEN1L
HLRZ AR1,(C)
MOVSI TT,-LOPMDS
OPEN1F: HRRZ R,OPMDS(TT)
CAIN AR1,(R)
JRST OPEN1K
AOBJN TT,OPEN1F
OPEN1G: HRRZ C,(C)
JRST OPEN1C
OPMDS: FBT<AP>+1,,Q$IN
FBT<AP>+1,,QOREAD
FBT<AP>+1,,Q$OUT
FBT<AP>+1,,Q%PRINT
FBT<AP>+1,,QAPPEND
000014,,Q$ASCII
000014,,QFIXNUM
000014,,QIMAGE
000002,,QDSK
FBT<CA>+2,,QCLA
000002,,QTTY
FBT<CM>,,QBLOCK
FBT<CM>,,QSINGLE
FBT<EC>,,QECHO
LOPMDS==.-OPMDS
OPBITS: 0 ;IN
0 ;READ
1 ;OUT
1 ;PRINT
FBT<AP>,,1 ;APPEND
0 ;ASCII
4 ;FIXNUM
10 ;IMAGE
0 ;DSK
FBT<CA>,,0 ;CLA
2 ;TTY
0 ;BLOCK
FBT<CM>,, ;SINGLE
FBT<EC>,, ;ECHO
IFN .-OPBITS-LOPMDS, .ERR WRONG LENGTH TABLE
OPEN1K: TDNN D,OPMDS(TT)
JRST OPEN1Z
OPEN1H: EXCH A,B
WTA [ILLEGAL OPTIONS LIST - OPEN!]
EXCH A,B
JRST OPEN0J
OPEN1Z: HLRZ R,OPMDS(TT)
TLO D,(R)
TLZ F,(R)
TRZ F,(R)
IOR F,OPBITS(TT)
JRST OPEN1G
;STATE OF THE WORLD:
; FIRST ARG TO OPEN IN A
; SECOND ARG IN B
; D CONTAINS BITS FOR ACTUALLY SPECIFIED OPTIONS
; IN LEFT HALF
; F CONTAINS BITS FOR OPTIONS:
; 4.9 FBT.CM 0 => BLOCK, 1 => SINGLE
; 4.5 FBT.AP 1 => APPEND
; 4.4 FBT.EC 1 => ECHO MODE OUTPUT TTY
; 2.9-2.4 WILL SOON CONTAIN HIGH SIX BITS FOR
; BYTE POINTER IF IN APPEND MODE
; 1.4-1.3 0 => ASCII, 1 => FIXNUM, 2 => IMAGE
; 1.2 0 => DSK, 1 => TTY
; 1.1 0 => IN, 1 => OUT
; ACTUAL NUMBER OF ARGS ON P
OPEN1L: TLNE D,FBT<CM>
JRST OPEN1Y
TRNE F,2 ;FOR TTY, DEFAULT TO SINGLE,
TLO F,FBT<CM> ; NOT BLOCK, MODE
OPEN1Y: TRC F,3
TRCE F,3
JRST OPEN1W
TLNN F,FBT<CM>
TLO F,FBT<SI> ;BUFFERED TTY OUTPUT USES SIOT
JRST OPEN1X
OPEN1W: TLZ F,FBT<EC> ;ECHO IS MEANINGFUL ONLY FOR TTY OUTPUT
OPEN1X: TRNN F,2 ;SKIP IF TTY
JRST OPEN1S
TLZ F,FBT<AP> ;CAN'T APPEND TO A TTY
TRNN F,1
TLO F,FBT<CM> ;CAN'T DO BLOCK TTY INPUT
TRNE F,4 ;FIXNUM TTY I/O USES FULL CAR SET
TLO F,FBT<FU>
OPEN1S: PUSH P,A
PUSH P,B
PUSH FXP,F
CAIE A,TRUTH ;T MEANS TTY FILE ARRAY:
JRST OPEN1M
TRNN F,1
SKIPA A,V%TYI ;TTY INPUT IF MODE BITS SAY INPUT
HRRZ A,V%TYO ; AND OUTPUT OTHERWISE
OPEN1M: PUSH P,A
PUSHJ P,FIL6BT ;GET FILE NAME SPECS
PUSHJ P,DMRGF ;MERGE IN DEFAULT NAMES
MOVE A,(P) ;GET (POSSIBLY MUNGED FOR T) FIRST ARG
JSP TT,AFILEP ;SKIP IF WE GOT A REAL LIVE SAR
JRST OPEN1N
PUSHJ P,ICLOSE ;CLOSE IT IF NECESSARY
MOVE A,(P)
MOVE D,-3(P) ;IF ONLY ONE ARG TO OPEN, AND
AOJE D,OPEN1Q ; THAT A SAR, RE-USE THE ARRAY
MOVE F,-4(FXP)
MOVEI TT,F.MODE
CAME F,@TTSAR(A)
JRST OPEN1P
PUSHJ P,OPNCLR ;IF TWO ARGS, BUT SAME MODE,
JRST OPEN1Q ; CLEAR ARRAY, THAN RE-USE
OPEN1N: MOVSI A,-1
OPEN1P: MOVE F,-4(FXP)
HLRZ TT,OPEN9A(F)
SKIPGE F
HRRZ TT,OPEN9A(F)
PUSHJ P,MKLSAR
OPEN1Q: LOCKI
;STATE OF THE WORLD:
; USER INTERRUPTS LOCKED OUT
; SAR FOR FILE ARRAY IN A
; P: FIRST ARG, OR TTY SAR IF ARG WAS T
; SECOND ARG TO OPEN
; FIRST ARG
; (NEGATIVE OF) ACTUAL NUMBER OF ARGS
; FXP: LOCKI WORD
; FILE NAME 2
; FILE NAME 1
; SNAME
; DEVICE NAME
; MODE BITS
MOVEI TT,-1
SETZM @TTSAR(A)
MOVE F,-5(FXP) ;GET MODE BITS
HLLZ TT,OPEN9B(F)
IORM TT,TTSAR(A) ;SET CLOSED BIT AND FILE TYPE BITS
MOVSI TT,AS<FIL>
IORB TT,ASAR(A) ;NOW CAN TURN ON FILE ARRAY BIT
MOVEI T,-F.GC
HRLM T,-1(TT) ;SET UP GC AOBJN POINTER
MOVEM A,(P) ;SAVE THE FILE ARRAY SAR
PUSHJ P,ALCHAN ;ALLOCATE A CHANNEL
JRST OPNALZ
MOVE TT,TTSAR(A)
HRRZM F,F.CHAN(TT)
POP FXP,T ;BEWARE THE LOCKI WORD!
POP FXP,F.FN2(TT)
POP FXP,F.FN1(TT)
10% POP FXP,F.SNM(TT)
10$ POP FXP,F.PPN(TT)
POP FXP,F.DEV(TT)
EXCH T,(FXP)
PUSH FXP,T
PUSH FXP,XC-1 ;WILL BECOME NON-NEG FOR RANDOM ACCESS
;STATE OF THE WORLD:
; USER INTERRUPTS LOCKED OUT
; TTSAR OF FILE ARRAY IN TT
; MODE BITS IN T
; P: SAR FOR FILE ARRAY
; SECOND ARG TO OPEN
; FIRST ARG
; -<# OF ACTUAL ARGS>
; FXP: -1 ;RANDOM ACCESS FLAG
; MODE BITS
; LOCKI WORD
;PDLS MUST STAY THIS WAY FROM NOW ON FOR THE SAKE OF IOJRST'S.
TLNN T,FBT<AP> ;SKIP IF APPENDING
JRST OPEN3
HLRZ D,OPEN9C-1(T) ;GET CORRESPONDING READ MODE (?)
SKIPGE T
HRRZ D,OPEN9C-1(T)
.CALL OPENUP
IOJRST 4,OPENLZ
.CALL RCHST
.VALUE
SKIPGE F.FPOS(TT) ;IF NOT RANDOM ACCESS, ASSUME
JRST OPEN3 ; NORMAL OUTPUT INSTEAD OF APPEND
.CALL FILLEN
IOJRST 4,OPENLZ
JUMPE F,OPEN3
SUBI F,1
TRNE T,4 ;FOR FIXNUM, DON'T HACK ↑C STUFF
JRST OPEN2B
OPEN2: .CALL ACCESS ;NOT COMPLETELY GENERAL FOR
.VALUE ; ALL BYTE SIZES **************
HRROI T,FB.BUF(TT)
.CALL IOTTTT
IOJRST 4,OPENLZ
MOVE T,[-5,,1]
MOVE D,FB.BUF(TT)
LSH D,-1
OPEN2A: LSHC D,-7
LSH R,-35
JUMPE R,OPEN2C
CAIE R,↑C
CAIN R,↑L
JRST OPEN2C
DPB T,[140600,,-1(FXP)] ;SAVE SIX BITS FOR BYTE POINTER
OPEN2B: MOVEM F,(FXP)
JRST OPEN3
OPEN2C: ADDI T,6
AOBJN T,OPEN2A
SOJA F,OPEN2
OPENUP: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,(D) ;I/O MODE BITS
,,F.CHAN(TT) ;CHANNEL #
,,F.DEV(TT) ;DEVICE NAME
,,F.FN1(TT) ;FILE NAME 1
,,F.FN2(TT) ;FILE NAME 2
400000,,F.SNM(TT) ;SNAME
FILLEN: SETZ
SIXBIT \FILLEN\ ;GET FILE LENGTH (IN WORDS)
,,F.CHAN(TT) ;CHANNEL #
402000,,F ;PUT RESULT IN F
ACCESS: SETZ
SIXBIT \ACCESS\ ;SET FILE ACCESS POINTER
,,F.CHAN(TT) ;CHANNEL #
400000,,F ;POSITION
RCHST: SETZ
SIXBIT \RCHST\ ;READ CHANNEL STATUS
,,F.CHAN(TT) ;CHANNEL #
2000,,F.RDEV(TT) ;DEVICE NAME
2000,,F.RFN1(TT) ;FILE NAME 1
2000,,F.RFN2(TT) ;FILE NAME 2
2000,,F.RSNM(TT) ;SNAME
402000,,F.FPOS(TT) ;ACCESS POINTER
IFN ITS,[
OPEN9A: ;SIZES FOR FILE ARRAYS: BLOCKMODE,,CHARMODE
IRPC X,,[AXI] ;ASCII/FIXNUM/IMAGE
IRPC Y,,[DT] ;DSK/TTY
IRPC Z,,[IO] ;IN/OUT
X!!Y!!Z!B.SZ,,X!!Y!!Z!C.SZ
TERMIN
TERMIN
TERMIN
OPEN9B: ;<TTSAR BITS>,,<BLOCK MODE BUFFER SIZE>
IRP X,,[A,X,I]J,,[,+BN,+IM] ;ASCII/FIXNUM/IMAGE
IRP Y,,[D,T]K,,[,+TY] ;DSK/TTY
IRP Z,,[I,O]L,,[,+IO] ;IN/OUT
TTS<CL!J!!K!!L>,,X!!Y!!Z!B.BS
TERMIN
TERMIN
TERMIN
;;; RECALL THE MEANINGS OF THE FOLLOWING BITS IN ITS:
;;; 1.3 0 => ASCII, 1 => IMAGE
;;; 1.2 0 => UNIT (CHARACTER) MODE, 1 => BLOCK MODE
;;; 1.1 0 => INPUT, 1 => OUTPUT
OPEN9C: ;ITS I/O MODE BITS: BLOCKMODE,,CHARMODE
2,, 0 ;ASCII DSK INPUT
3,, 1 ;ASCII DSK OUTPUT
0,, 0 ;ASCII TTY INPUT
%TJ<DIS>+1,,%TJ<DIS>+1 ;ASCII TTY OUTPUT (DISPLAY IF POSSIBLE)
6,, 4 ;FIXNUM DSK INPUT
7,, 5 ;FIXNUM DSK OUTPUT
%TI<FUL>+0,,%TI<FUL>+0 ;FIXNUM TTY INPUT (>7 BITS ON IMLACS AND TVS)
%TJ<DIS>+1,,%TJ<DIS>+1 ;FIXNUM TTY OUTPUT
2,, 0 ;IMAGE DSK INPUT
3,, 1 ;IMAGE DSK OUTPUT
0,, 0 ;IMAGE TTY INPUT (SUPER-IMAGE INPUT)
%TJ<SIO>+1,,%TJ<SIO>+1 ;IMAGE TTY OUTPUT (SUPER-IMAGE OUTPUT)
OPEN9D: ;WORD FOR FB.BYT: <LH OF BYTE POINTER>,,<BYTES PER WORD>
010700,,5 ;ASCII DSK INPUT
010700,,5 ;ASCII DSK OUTPUT
0 ;ASCII TTY INPUT (IRRELEVANT)
010700,,5 ;ASCII TTY OUTPUT
0 ;FIXNUM DSK INPUT (IRRELEVANT)
0 ;FIXNUM DSK OUTPUT (IRRELEVANT)
0 ;FIXNUM TTY INPUT (IRRELEVANT)
001400,,3 ;FIXNUM TTY OUTPUT
010700,,5 ;IMAGE DSK INPUT
010700,,5 ;IMAGE DSK OUTPUT
0 ;IMAGE TTY INPUT (IRRELEVANT)
041000,,4 ;IMAGE TTY OUTPUT
] ;END OF IFN ITS
OPEN3: MOVE T,-1(FXP) ;GET MODE BITS
TRZ T,770000 ;CLEAR OUT BYTE POINTER CRAP
MOVEM T,F.MODE(TT) ;SAVE IN FILE ARRAY
HLRZ D,OPEN9C(T)
SKIPGE T
HRRZ D,OPEN9C(T)
TLNE T,FBT<AP> ;APPEND MODE =>
TRO D,100000 ; ITS WRITE-OVER MODE
TLNE T,FBT<EC> ;MAYBE OPEN AN OUTPUT TTY
TRO D,%TJ<PP2> ; IN THE ECHO AREA
.CALL OPENUP
IOJRST 4,OPENLZ
.CALL RFNAME
.VALUE
TLNN T,FBT<CA>
JRST OPEN3H
MOVEI T,F.RFN1(TT) ; WHICH ARE THE SIXBIT FOR THE
HRLI T,-2 ; UNAME-JNAME OF THE SENDER, AND
.CALL IOTTTT ; USE THEM FOR THE TRUENAMES
IOJRST 4,OPENLZ ; OF THE FILE ARRAY.
MOVE T,-1(FXP) ;RESTORE MODE BITS
TRZ T,770000
OPEN3H: TRNN T,1
SKIPA D,DEOFFN ;FOR INPUT, GET THE EOFFN
HRRZ D,DENDPAGEFN ;FOR OUTPUT, THE ENDPAGEFN
MOVEM D,FI.EOF(TT) .SEE FO.EOP
SETZM FI.BBC(TT) .SEE FO.LNL
SETZM FI.BBF(TT) .SEE FO.PGL
HRRZ D,OPEN9B ;***** FOR DEC-10, WILL HAVE
SKIPL T ; TO USE THE DEVSIZ UUO
MOVEM D,FB.BFL(TT) ; TO DETERMINE BUFFER SIZE
JRST @.+1(T)
OPNAI1 ;ASCII DSK INPUT
OPNAO1 ;ASCII DSK OUTPUT
OPNTI1 ;ASCII TTY INPUT
OPNTO1 ;ASCII TTY OUTPUT
OPNBI1 ;FIXNUM DSK INPUT
OPNBO1 ;FIXNUM DSK OUTPUT
OPNTI1 ;FIXNUM TTY INPUT
OPNTO1 ;FIXNUM TTY OUTPUT
OPNAI1 ;IMAGE DSK INPUT
OPNAO1 ;IMAGE DSK OUTPUT
OPNTI1 ;IMAGE TTY INPUT
OPNTO1 ;IMAGE TTY OUTPUT
OPNAO1: MOVE D,DPAGEL ;DEFAULT PAGEL
MOVEM D,FO.PGL(TT)
MOVE D,DLINEL ;DEFAULT LINEL
MOVEM D,FO.LNL(TT)
JUMPL T,OPNA3 .SEE FBT.CM
MOVE D,FB.BFL(TT)
ADDM D,F.FPOS(TT)
OPNAI1:
OPNA6: JUMPL T,OPNA3 .SEE FBT.CM
MOVN D,FB.BFL(TT)
HRLI D,FB.BUF(TT)
MOVSM D,FB.IOT(TT)
MOVE D,OPEN9D(T)
MOVEM D,FB.BYT(TT)
MOVE D,FB.BFL(TT)
IMULI D,@FB.BYT(TT)
TRNN T,1
SETZ D,
MOVEM D,AB.CNT(TT)
HLLZ D,FB.BYT(TT)
JRST OPNA3A
OPNA3: SETZ D,
OPNA3A: SKIPGE F,(FXP)
JRST OPNA2
HRL D,-1(FXP) ;NOT COMPLETELY GENERAL FOR
TLZ D,7777 ; ALL BYTE SIZES ***************
TLO D,0700
.CALL ACCESS
IOJRST 4,OPENLZ
ADDI F,1
ADDM F,F.FPOS(TT)
HRRI D,FPOS3
LDB R,D
HRRI D,1
MOVNI R,(R)
SKIPL T
ADDM R,AB.CNT(TT)
OPNA2: JUMPL T,OPNAT3 .SEE FBT.CM
ADDI D,FB.BUF-1(TT)
TRNN T,1
ADD D,FB.BFL(TT)
MOVEM D,AB.BP(TT)
JRST OPNAT3
OPNTI1: SETZM TI.BFN(TT)
MOVE D,[STTYW1]
MOVEM D,TI.ST1(TT)
MOVE D,[STTYW2]
MOVEM D,TI.ST2(TT)
.CALL TTYGET
IOJRST 4,OPENLZ
;TURN OFF SCROLLING, AUTO-INT, SUPER-IMAGE
TLZ F,%TS<ROL+INT+SII>
TRNE T,10 ;TTY IMAGE INPUT =>
TLO F,%TS<SII> ; ITS SUPER-IMAGE INPUT
.CALL TTYSET
IOJRST 4,OPENLZ
SETZM FT.CNS(TT)
JRST OPNAT3
TTYGET: SETZ
SIXBIT \TTYGET\ ;GET TTYST1, TTYST2, TTYSTS
,,F.CHAN(TT) ;TTY CHANNEL #
2000,,D ;TTYST1
2000,,R ;TTYST2
402000,,F ;TTYSTS
TTYSET: SETZ
SIXBIT \TTYSET\ ;SET TTYST1, TTYST2, TTYSTS
,,F.CHAN(TT) ;TTY CHANNEL #
,,TI.ST1(TT) ;TTYST1
,,TI.ST2(TT) ;TTYST2
400000,,F ;TTYSTS
OPNTO1: .CALL CNSGET
IOJRST 4,OPENLZ
MOVSI R,200000 ;INFINITE PAGEL INITIALLY
MOVEM R,FO.PGL(TT)
SOS FO.LNL(TT)
SETZ R,
TLNE D,%TO<SA1> ;SKIP UNLESS WE HAVE SAIL CHARS
TLO R,FBT<SA> ;SET SAIL BIT
TLNE D,%TO<MVU> ;IF WE CAN MOVE UP, ASSUME WE
TLO R,FBT<CP> ; CAN CURSORPOS IN GENERAL (?)
TLNE D,%TO<ERS> ;REMEMBER THE SELECTIVE ERASE BIT
TLO R,FBT<SE> .SEE RUB1CH
IORB R,F.MODE(TT)
SETZM FT.CNS(TT)
TLNN R,FBT<EC>
JRST OPNA6
.CALL SCML
.VALUE
.CALL TTYGET
.VALUE
TLZ F,%TS<FCO>
TLNE R,FBT<FU>
TLO F,%TS<FCO>
.CALL TTYSAC
.VALUE
JRST OPNA6
SCML: SETZ
SIXBIT \SCML\ ;SET NUMBER OF COMMAND LINES
,,F.CHAN(TT) ;TTY CHANNEL #
401000,,5 ;NUMBER OF LINES
CNSGET: SETZ
SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS
,,F.CHAN(TT) ;TTY CHANNEL #
2000,,FO.PGL(TT) ;VERTICAL SCREEN SIZE
2000,,FO.LNL(TT) ;HORIZONTAL SCREEN SIZE
2000,,D ;TCTYP (THROW AWAY)
2000,,D ;TTYCOM (THROW AWAY)
402000,,D ;TTYOPT
;TTYTYP NOT GOTTEN
OPNBO1: JUMPL T,OPNB2 .SEE FBT.CM
MOVE D,FB.BFL(TT)
ADDM D,F.FPOS(TT)
OPNBI1: JUMPL T,OPNB2 .SEE FBT.CM
MOVN D,FB.BFL(TT)
HRLI D,FB.BUF(TT)
MOVSM D,FB.IOT(TT)
MOVEI R,FB.BUF(TT)
ADD R,FB.BFL(TT)
TRNN T,1
MOVSI D,(R)
MOVSM D,XB.AOB(TT)
OPNB2: SKIPGE F,(FXP)
JRST OPEN4
.CALL ACCESS
IOJRST 4,OPENLZ
ADDM F,F.FPOS(TT)
JRST OPEN4
OPNAT3: SETZM AT.CHS(TT)
SETZM AT.LNN(TT)
MOVEI D,1
MOVEM D,AT.PGN(TT)
OPEN4: POP P,A ;SAR FOR FILE ARRAY - RETURNED
MOVSI TT,TTS<CL>
ANDCAM TT,TTSAR(A) ;UNCLOSE IT
SUB P,R70+3 ;FLUSH 2 ARGS AND # OF ARGS
SUB FXP,R70+2 ;FLUSH ACCESS FLAG AND MODE BITS
UNLKPOPJ
OPNALZ: MOVEI C,[SIXBIT \ALL I/O CHANNELS ALREADY IN USE!\]
POP FXP,-5(FXP) ;FAKE OUT CORRECT PDL CONDITIONS
SUB FXP,R70+2
OPENLZ: MOVE F,F.CHAN(TT) ;REMEMBER, C HAS ERROR MSG
SETZM CHNTB(F) ;CLOSE CHANNEL AND DEALLOCATE
.CALL ALCHN9
.VALUE
POP P,AR1
POP P,A ;SECOND ARG
POP P,B ;FIRST ARG
POP P,T ;ARG COUNT
JUMPN T,OPNLZ1
MOVEI A,(AR1)
PUSHJ P,NAMELIST
JRST OPNLZ2
OPNLZ1: PUSHJ P,ACONS
EXCH A,B
PUSHJ P,ACONS
CAMN T,XC-2
HRRM B,(A)
OPNLZ2: MOVEI B,Q$OPEN
SUB FXP,R70+2 ;FLUSH 2 FXP WORDS
UNLOCKI
JRST XCIOL
SUBTTL DEFAULTF, ENDPAGEFN, EOFFN
;;; (DEFAULTF X) SETS THE DEFAULT NAMELIST TO X.
;;; X IS MERGEF'D WITH THE OLD NAMELIST FIRST.
;;; IT FOLLOWS THAT (DEFAULTF NIL) = (NAMELIST NIL).
DEFAULTF: PUSHJ P,FIL6BT
PUSHJ P,DMRGF
PUSHJ P,6BTNML
MOVEM A,VDEFAULTF
POPJ P,
SSCRFILE==DEFAULTF
;;; (EOFFN F) GETS INPUT FILE F'S END-OF-FILE FUNCTION.
;;; (EOFFN F X) SETS THE FUNCTION TO BE X.
;;; (ENDPAGEFN F) GETS OUTPUT FILE F'S END-OF-PAGE FUNCTION.
;;; (ENDPAGEFN F X) SETS IT TO BE X.
ENDPAGEFN: JSP TT,LWNACK ;LSUBR (1 . 2)
LA12,,QENDPAGEFN
MOVEI TT,ATOFOK
MOVEI B,DENDPAGEFN
JRST EOFFN0
EOFFN: JSP TT,LWNACK ;LSUBR (1 . 2)
LA12,,QEOFFN
MOVEI TT,IFILOK
MOVEI B,DEOFFN
EOFFN0: AOJN T,EOFFN5
POP P,AR1
JUMPE AR1,EOFFN2
PUSHJ P,(TT)
MOVEI TT,FI.EOF .SEE FO.EOP
HRRZ A,@TTSAR(AR1)
UNLKPOPJ
EOFFN2: HRRZ A,(B)
POPJ P,
EOFFN5: POP P,A
POP P,AR1
JUMPE AR1,EOFFN7
PUSHJ P,(TT)
MOVE TT,TTSAR(AR1)
HRRZM A,FI.EOF(TT) .SEE FO.EOP
UNLKPOPJ
EOFFN7: HRRZM A,(B)
POPJ P,
SUBTTL LISTEN FUNCTION
;;; (LISTEN) LISTENS TO THE CONSOLE.
;;; (LISTEN X) LISTENS TO THE SPECIFIED TTY X.
$LISTEN: SKIPA F,CFIX1 ;LSUBR (0 . 1) NCALLABLE
MOVEI F,CPOPJ
JUMPN T,$LSTN2
.LISTEN TT,
JRST (F)
$LSTN2: MOVEI D,Q$LISTEN
AOJN T,S1WNAL
POP P,AR1 ;FILE ARRAY SPECIFIED
PUSHJ P,TIFLOK ;IT BETTER BE TTY INPUT
.CALL LISTEN ;SO LISTEN ALREADY
SETZ R,
MOVEI TT,FI.BBC
MOVE A,@TTSAR(AR1) ;ALSO COUNT IN ANY BUFFERED
TLZE A,-1 ; UP CHARACTERS PENDING
AOS R
JSP T,LNG1A
ADD TT,R
UNLOCKI
JRST (F)
LISTEN: SETZ
SIXBIT \LISTEN\ ;LISTEN AT A TTY, ALREADY
,,F.CHAN(TT) ;TTY CHANNEL #
402000,,R ;NUMBER OF TYPED-AHEAD CHARS
SUBTTL LINEL, PAGEL, CHARPOS, LINENUM, PAGENUM
;;; VARIOUS FUNCTIONS TO GET AND SET A FILE'S LINEL, PAGEL,
;;; CHARPOS, LINENUM, AND PAGENUM.
LINEL: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
FO.LNL,,QLINEL
DLINEL,,ATOFOK
PAGEL: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
FO.PGL,,QPAGEL
DPAGEL,,ATOFOK
CHARPOS: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.CHS,,QCHARPOS
0,,ATOFOK
LINENUM: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.LNN,,QLINEL
0,,ATFLOK
PAGENUM: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.PGN,,QPAGENUM
0,,ATFLOK
FLFROB: AOJN T,FLFRB5
PUSH P,AR1
MOVE AR1,-1(P)
MOVEM D,-1(P)
JUMPE AR1,FLFRB3
FLFRB1: HRRZ TT,1(F)
PUSHJ P,(TT)
HLRZ TT,(F)
MOVM TT,@TTSAR(AR1) .SEE STERPRI ;LINEL MAY BE NEGATIVE
UNLOCKI
FLFB1A: POP P,AR1
POPJ P,
FLFRB3: HLRZ TT,1(F)
JUMPE TT,FLFRB1
MOVE TT,(TT)
JRST FLFB1A
FLFRB5: POP P,A
JSP T,FXNV1
PUSH P,AR1
MOVE AR1,-1(P)
MOVEM D,-1(P)
MOVE D,TT
JUMPE AR1,FLFRB7
FLFRB6: HRRZ TT,1(F)
PUSHJ P,(TT)
HLRZ TT,(F)
MOVMS D
EXCH D,@TTSAR(AR1)
SKIPGE D
MOVNS @TTSAR(AR1)
UNLOCKI
FLFRB8: MOVE TT,D
JRST FLFB1A
FLFRB7: HLRZ TT,1(F)
JUMPE TT,FLFRB6
MOVMM D,(TT)
JRST FLFRB8
SUBTTL IN
;;; (IN X) INPUTS ONE FIXNUM FROM THE BINARY FILE X AND
;;; RETURNS IT.
$IN: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE
PUSH P,AR1
MOVEI AR1,(A)
PUSHJ P,XIFLOK
SKIPL F.MODE(TT) .SEE FBT.CM
JRST $IN2
MOVE F,F.CHAN(TT)
LSH F,27
IOR F,[.IOT TT]
AOS F.FPOS(TT)
XCT F
$IN1: POP P,AR1
UNLKPOPJ
$IN2: SKIPL T,XB.AOB(TT)
JRST $IN6
MOVE D,(T)
ADD T,R70+1
MOVEM T,XB.AOB(TT)
MOVE TT,D
JRST $IN1
$IN6: MOVE T,FB.IOT(TT)
MOVEM T,XB.AOB(TT)
MOVE F,F.CHAN(TT)
LSH F,27
IOR F,[.IOT T]
MOVE D,FB.BFL(TT)
ADDM D,F.FPOS(TT)
XCT F
JUMPGE T,$IN2
CAMN T,FB.IOT(TT)
JRST $IN7
SUB T,FB.IOT(TT)
MOVNI T,(T)
HRLM T,XB.AOB(TT)
JRST $IN2
$IN7: MOVEI A,(AR1)
HRRZ T,FI.EOF(TT)
SETZM XB.AOB(TT)
UNLOCKI
POP P,AR1
JUMPE T,$IN8
JCALLF 1,(T)
$IN8: PUSH P,B
PUSHJ P,NCONS
MOVEI B,Q$IN
PUSHJ P,XCONS
POP P,B
IOL [EOF - IN!]
SUBTTL OUT
;;; (OUT X N) OUTPUTS THE FIXNUM N TO THE FILE X. RETURNS T.
$OUT: PUSH P,AR1
JSP T,FXNV2
MOVEI AR1,(A) ;SUBR 2
PUSHJ P,XOFLOK
SKIPL F.MODE(TT) .SEE FBT.CM
JRST $OUT4
MOVE F,F.CHAN(TT)
LSH F,27
IOR F,[.IOT D]
AOS F.FPOS(TT)
XCT F
$OUT1: POP P,AR1
JRST UNLKTRUE
$OUT4: MOVE T,XB.AOB(TT)
MOVEM D,(T)
AOBJP T,$OUT7
MOVEM T,XB.AOB(TT)
JRST $OUT1
$OUT7: MOVE T,FB.IOT(TT)
MOVEM T,XB.AOB(TT)
MOVE F,F.CHAN(TT)
LSH F,27
IOR F,[.IOT T]
MOVE D,FB.BFL(TT)
ADDM D,F.FPOS(TT)
XCT F
JRST $OUT1
SUBTTL FILEPOS
;;; FILEPOS FUNCTION
;;; (FILEPOS F) RETURNS CURRENT FILE POSITION
;;; (FILEPOS F N) SETQ FILEPOS TO X
;;; FOR ASCII FILES, THE POSITION IS MEASURED IN CHARACTERS;
;;; FOR FIXNUM FILES, IN FIXNUMS (WORDS). ZERO IS THE
;;; BEGINNING OF THE FILE. ERROR IF FILE IS NOT RANDOMLY
;;; ACCESSIBLE.
;;; ***** SETTING NOT IMPLEMENTED FOR OUTPUT FILES YET *****
FILEPOS:
AOJE T,FPOS1 ;ONE ARG => GET
AOJE T,FPOS5 ;TWO ARGS => SET
MOVEI D,QFILEPOS ;ARGH! ARGH! ARGH! ...
JRST S2WNALOSE
FPOS0B: SKIPA C,FPOS0
FPOS0C: MOVEI C,[SIXBIT \ILLEGAL ACCESS POINTER!\]
MOVEI A,(B)
PUSHJ P,NCONS
JRST FPOS0A
FPOS0: MOVEI C,[SIXBIT \FILE NOT RANDOMLY ACCESSIBLE!\]
SETZ A,
FPOS0A: MOVEI B,(AR1)
PUSHJ P,XCONS
MOVEI B,QFILEPOS
UNLOCKI
JRST XCIOL
FPOS1: POP P,AR1 ;ARG IS FILE
PUSHJ P,FILOK ;DOES LOCKI
SKIPGE D,F.FPOS(TT) ;LOSE IF NOT RANDOMLY ACCESSIBLE
JRST FPOS0
SKIPGE F.MODE(TT) ;SKIP IF BUFFERED
JRST FPOS1A ;ELSE F.FPOS HAS THE RIGHT THING
TLNE TT,TTS<BN>
JRST FPOS4
ADDI D,@AB.BP(TT) ;BUFFERED ASCII
SUBI D,FB.BUF(TT)
SUB D,FB.BFL(TT)
IMULI D,BYTSWD ;MUST GET IN TERMS OF CHARS
MOVEI R,FPOS3
HLL R,AB.BP(TT) ;ADJUST FOR WHICH BYTE
LDB R,R
ADDI D,(R)
FPOS1A: TLNN TT,TTS<IO>
SKIPN B,FI.BBC(TT)
JRST FPOS2
TLZE B,-1 ;ALLOW FOR ANY BUFFERED BACK CHARS
SUBI D,1
FPOS1C: JUMPE B,FPOS2
HRRZ B,(B)
SOJGE D,FPOS1C
SETZ D, ;?? RAN OFF BEGINNING
FPOS2: MOVE TT,D ;RETURN POSITION AS FIXNUM
UNLOCKI
JRST FIX1
FPOS3:
.BYTE 7
1 ? 2 ? 3 ? 4 ? 5 ;MAGIC TABLE
.BYTE
FPOS4: SKIPL R,XB.AOB(TT) ;BUFFERED FIXNUMS
JRST FPOS2
ADDI D,(R)
SUBI D,FB.BUF(TT)
SUB D,FB.BFL(TT)
JRST FPOS2
FPOS5: POP P,B ;SECOND ARG IS FIXNUM
POP P,AR1 ;FIRST IS FILE
JSP T,FXNV2
PUSHJ P,FILOK ;DOES LOCKI
JUMPL D,FPOS0C ;CHECK OUT ACCESS POINTER
.CALL FILLEN ;MUST BE WITHIN FILLEN
JRST FPOS5C ;ASSUME OK (CROCK FOR USR DEVICE)
TLNN TT,TTS<BN>
IMULI F,BYTSWD
CAMLE D,F
JRST FPOS0C
FPOS5C: TLNN TT,TTS<IO> ;*** OUTPUT LOSES ***
SKIPGE F.FPOS(TT) ;ALSO IF NOT RANDOM ACCESS
JRST FPOS0B
TLNE TT,TTS<BN>
JRST FPOS7
SETZM FI.BBC(TT) ;CLEAR OUT BUFFERED BACK CHARS
SETZM FI.BBF(TT) ;CLEAR OUT BUFFERED BACK FORMS
MOVE F,D ;ASCII FILE
IDIVI D,BYTSWD
.CALL FPOS9 ;SET ITS ACCESS POINTER
.VALUE
SKIPGE F.MODE(TT)
JRST FPOS6
MOVEM D,F.FPOS(TT) ;FOR BUFFERED ASCII,
MOVE T,TT ; SET UP THE BUFFER
PUSHJ P,$DEV5K
SETZB R,AB.CNT(T) ;IN CASE OF EOF
JUMPE R,UNLKTRUE
FPOS5A: IBP AB.BP(T) ;ALSO DIDDLE THE BYTE POINTER
SOSGE AB.CNT(T)
.VALUE ;JUST IN CASE!
SOJG R,FPOS5A
JRST UNLKTRUE
FPOS6: MOVEM F,F.FPOS(TT) ;FOR UNIT ASCII,
JUMPE R,UNLKTRUE ; GOBBLE ENOUGH CHARACTERS
FPOS6A: .CALL IOTTTT ; TO POSITION WITHIN THE WORD
.VALUE
SOJG R,FPOS6A
JRST UNLKTRUE
FPOS7: .CALL FPOS9 ;FOR FIXNUMS, SET ITS ACCESS POINTER
.VALUE
MOVEM D,F.FPOS(TT)
SKIPGE F.MODE(TT)
JRST UNLKTRUE
MOVEI D,FB.BUF(TT)
ADD D,FB.BFL(TT)
MOVEM D,XB.AOB(TT)
JRST UNLKTRUE
FPOS9: SETZ
SIXBIT \ACCESS\ ;SET FILE ACCESS POINTER
,,F.CHAN(TT) ;CHANNEL NUMBER
400000,,D ;ACCESS POINTER
SUBTTL CONTROL-P CODES AND TTY INITIALIZATION
;;; PUSH A ↑P CODE INTO A TTY FILE ARRAY IN AR1.
;;; THE CHARACTER TO FOLLOW THE ↑P IS IN D.
;;; IF THE CHARACTER IS "H, "I, OR "V, THEN THE SECOND
;;; CHARACTER IS IN THE LEFT HALF OF D.
;;; CHARPOS, LINENUM, AND PAGEL ARE CORRECTLY UPDATED.
;;; I/O LOSSES DUE TO INTERRUPTS BETWEEN ↑P AND THE
;;; NEXT CHARACTER ARE SCRUPULOUSLY AVOIDED.
;;; CLOBBERS T, TT, D, AND F. SAVES R (SEE RUB1C3).
CNPCOD: .5LKTOPOPJ .SEE INTTYR
HLLOS NOQUIT
MOVE T,TTSAR(AR1)
MOVE TT,F.MODE(T)
TLNN TT,FBT<CP>
JRST CZECHI
PUSH FXP,D
JUMPL TT,CNPCD1 .SEE FBT.CM
MOVE TT,AB.CNT(T)
SUBI TT,3
JUMPGE TT,CNPCD1
MOVE TT,T
PUSHJ P,IFORCE
MOVE T,TTSAR(AR1)
CNPCD1: MOVEI TT,↑P
PUSHJ P,TYOF6
HRRZ TT,(FXP)
PUSHJ P,TYOF6
HLRZ TT,(FXP)
JUMPE TT,CNPCD2
TRZ TT,400000
PUSHJ P,TYOF6
CNPCD2: POP FXP,TT
CAIN TT,135 ;CLOSE BRACKET - NEEDS NO HAIR
JRST CZECHI
JRST CNPC9-"A(TT)
CNPC9: JRST CNP.A ;A ADVANCE TO FRESH LINE
JRST CNP.B ;B MOVE BACK 1, WRAPAROUND
JRST CNP.C ;C CLEAR SCREEN
JRST CNP.D ;D MOVE DOWN, WRAPAROUND
JRST CZECHI ;E CLEAR TO EOF
JRST CNP.F ;F MOVE FORWARD 1, WRAPAROUND
.LOSE
JRST CNP.H ;H SET HORIZONTAL POSITION
JRST CNP.I ;I TREAT NEXT CHARACTER AS ONE-POSITION PRINTING CHAR
.LOSE
JRST CZECHI ;K KILL CHARACTER UNDER CURSOR
JRST CZECHI ;L CLEAR TO END OF LINE
JRST CNP.M ;M GO INTO **MORE** STATE, THEN HOME UP
JRST CZECHI ;N GO INTO **MORE** STATE
.LOSE
.LOSE ;P OUTPUT A ↑P
.LOSE ;Q OUTPUT A ↑C
.LOSE ;R RESTORE CURSOR POSITION
.LOSE ;S SAVE CURSOR POSITION
JRST CNP.T ;T TOP OF SCREEN (HOME UP)
JRST CNP.U ;U MOVE UP, WRAPPING AROUND
JRST CNP.V ;V SET VERTICAL POSITION
.LOSE
JRST CNP.X ;X BACKSPACE AND ERASE ONE CHAR
.LOSE
JRST CNP.Z ;Z HOME DOWN
CNP.X: ;SAME AS ↑P K ↑P B
CNP.B: MOVE D,FO.LNL(T) ;MOVE BACKWARDS
SUBI D,1
SOSGE AT.CHS(T) ;WRAP AROUND IF AT LEFT MARGIN
MOVEM D,AT.CHS(T)
JRST CZECHI
CNP.M: ;DOES **MORE**, THEN HOMES UP
CNP.C: AOS AT.PGN(T) ;CLEAR SCREEN - AOS PAGENUM
CNP.T: SETZM AT.CHS(T) ;HOME UP - ZERO OUT CHARPOS
SETZM AT.LNN(T) ; AND LINENUM
JRST CZECHI
CNP.A: SKIPN AT.CHS(T) ;CRLF, UNLESS AT START OF LINE
JRST CZECHI
SETZM AT.CHS(T) ;CLEAR CHARPOS, THEN INCR LINENUM
CNP.D: AOS D,AT.LNN(T) ;MOVE DOWN
CAML D,FO.PGL(T) ;WRAP AROUND OFF BOTTOM TO TOP
SETZM AT.LNN(T)
JRST CZECHI
CNP.F: AOS D,AT.CHS(T) ;MOVE FORWARD - WRAP AROUND
CAML D,FO.LNL(T) ; OFF END TO LEFT MARGIN
SETZM AT.CHS(T)
JRST CZECHI
CNP.H: HLRZ D,TT ;SET HORIZONTAL POSITION
SUBI D,7
CAMLE D,FO.LNL(T) ;PUT ON RIGHT MARGIN IF TOO BIG
MOVE D,FO.LNL(T)
SUBI D,1
MOVEM D,AT.CHS(T)
JRST CZECHI
CNP.I: AOS AT.CHS(T) ;NOT REALLY THE RIGHT THING, BUT CLOSE
JRST CZECHI
CNP.Z: SETZM AT.LNN(T) ;HOME DOWN (GO UP FROM TOP!)
CNP.U: MOVE D,FO.PGL(T) ;MOVE UP
SUBI D,1 ;WRAP AROUND FROM TOP TO BOTTOM
SOSGE AT.LNN(T)
MOVEM D,AT.LNN(T)
JRST CZECHI
CNP.V: HLRZ D,TT ;SET VERTICAL POSITION
SUBI D,7 ;IF TOO LARGE, PUT ON BOTTOM
CAMLE D,FO.PGL(T)
MOVE D,FO.PGL(T)
SUBI D,1
MOVEM D,AT.LNN(T)
JRST CZECHI
;;; VARIOUS ROUTINES FOR PRINTING ↑P CODES
CNPBBL: MOVEI D,"B
PUSHJ P,CNPCOD
CNPBL: MOVEI D,"B
PUSHJ P,CNPCOD
CNPL: MOVEI D,"L
JRST CNPCOD
CNPU: MOVEI D,"U
JRST CNPCOD
CNPF: MOVEI D,"F
JRST CNPCOD
CLRSRN: MOVEI D,"C
JRST CNPCOD
;;; ROUTINE FOR OPENING UP THE INITIAL TTY FILE ARRAYS.
;;; SKIPS ON SUCCESS (FAILS IF THIS JOB NEVER HAD THE TTY).
OPNTTY: .SUSET [.RTTY,,T] ;GET .TTY USER VARIABLE
TLNE T,%TB<NVR> ;FAIL IF WE NEVER HAD THE TTY
COPNT1: POPJ P,OPNT1
AOS (P)
HRRZ A,V%TYO
MOVEI TT,FO.EOP
PUSH P,@TTSAR(A)
PUSH P,COPNT1 ;OPEN UP TTY OUTPUT ARRAY
PUSH P,A
MOVNI T,1
JRST $OPEN
OPNT1: MOVEI AR1,(A)
POP P,A
MOVEI TT,FO.EOP
MOVEM A,@TTSAR(AR1)
MOVEI TT,FO.LNL
MOVE TT,@TTSAR(AR1)
MOVEM TT,DLINEL ;SET UP DEFAULT LINEL FROM INITIAL JOB CONSOLE
MOVEI TT,FO.PGL
MOVE TT,@TTSAR(AR1)
MOVEM TT,DPAGEL ;SET UP DEFAULT PAGEL "
PUSH P,[OPNT1A]
PUSH P,AR1
MOVNI T,1
JRST STTYTYPE
OPNT1A: MOVEM A,VTTY ;INITIALIZE "TTY" TO (STATUS TTYTYPE)
HRRZ A,V%TYI
MOVEI TT,TI.BFN
PUSH P,@TTSAR(A)
MOVEI TT,TI.ST1
PUSH FXP,@TTSAR(A)
MOVEI TT,TI.ST2
PUSH FXP,@TTSAR(A)
PUSH P,COPNT2 ;OPEN UP TTY INPUT ARRAY
PUSH P,V%TYI
MOVNI T,1
JRST $OPEN
OPNT2: POP FXP,R ;BEWARE THE LOCKI WORD!
POP FXP,D
LOCKI
MOVE TT,TTSAR(A)
MOVEM D,TI.ST1(TT)
MOVEM R,TI.ST2(TT)
.CALL TTY2ST
.VALUE
POP P,TI.BFN(TT)
UNLOCKI
HRRZ A,V%TYI
HRRZ B,V%TYO
PUSHJ P,SSTTYCONS ;CONS THEM TOGETHER AS CONSOLE
COPNT2: POPJ P,OPNT2
SUBTTL CLEAR-INPUT, CLEAR-OUTPUT
;;; (CLEAR-INPUT X) CLEARS ANY PENDING INPUT.
;;; CURREENTLY ONLY EFFECTIVE FOR TTY'S.
CLRIN: PUSH P,AR1
MOVEI AR1,(A)
PUSHJ P,IFILOK
TLNE TT,TTS<TY>
PUSHJ FXP,CLRI3
JRST $OUT1
CLRI3: .CALL CLRIN9 ;RESET TTY INPUT AT ITS LEVEL
.VALUE
SETZM FI.BBC(TT) ;CLEAR BUFFERED-BACK CHARS
SETZM FI.BBF(TT) ;CLEAR BUFFERED-BACK FORMS
POPJ FXP,
CLRIN9: SETZ
SIXBIT \RESET\ ;RESET I/O CHANNEL
400000,,F.CHAN(TT) ;CHANNEL #
;;; (CLEAR-OUTPUT X) CLEARS ANY OUTPUT NOT ACTUALLY ON
;;; THE OUTPUT DEVICE YET. CURRENTLY ONLY EFFECTIVE FOR TTY'S.
CLROUT: PUSH P,AR1
MOVEI AR1,(A)
PUSHJ P,OFILOK
TLNE TT,TTS<TY> ;SKIP IF TTY
PUSHJ FXP,CLRO3
JRST $OUT1
CLRO3: .CALL CLRIN9 ;RESET CHANNEL
.VALUE
.CALL RCPOS1 ;RESET CHARPOS AND LINEL
.VALUE
HLL T,F.MODE(TT)
TLNE T,FBT<EC>
MOVE D,R
HLRZM D,AT.CHS(TT)
HRRZM D,AT.LNN(TT)
TLNN T,FBT<CM> ;IF BLOCK MODE, RESET
JSP D,FORCE6 ; LISP BUFFER POINTERS
POPJ FXP,
RCPOS1: SETZ
SIXBIT \RCPOS\ ;READ CURSOR POSITION
,,F.CHAN(TT) ;CHANNEL #
2000,,D ;MAIN CURSOR POSITION
402000,,R ;ECHO CURSOR POSITION
;;; STANDARD **MORE** PROCESSOR
TTYMOR: PUSHJ P,STTYCONS ;SUBR 1
JUMPE A,CPOPJ ;STTYCONS LEFT ARG IN AR1
STRT AR1,[SIXBIT \####MORE####!\] ;# IS QUOTE CHAR
PUSH P,AR1
PUSH P,[TTYMO2] ;FOR %TYI
PUSH P,A
PUSH P,[TTYMO1] ;FOR TYIPEEK
PUSH P,R70
PUSH P,A
MOVNI T,2
JRST TYIPEEK+1
TTYMO1: MOVNI T,1
CAIE TT,40
CAIN TT,177
JRST %TYI+1 ;SWALLOW SPACE OR RUBOUT
SUB P,R70+2
TTYMO2: POP P,AR1
MOVE D,[10,,"H] ;GO TO BEGINNING OF LINE
PUSHJ P,CNPCOD
PUSHJ P,CNPL ;CLEAR TO END OF LINE
MOVEI D,"T ;GO TO TOP OF SCREEN
PUSHJ P,CNPCOD
JRST CNPL ;CLEAR THAT LINE TOO
PGTOP QIO,[NEW I/O PACKAGE]
;;@ END OF QIO 248
] ;END OF IFN QIO
SUBTTL INTERRUPT HANDLERS
PGBOT INT
IFE QIO,[
IFN ITS,[
;;; ***** MOBY INTERRUPT ROUTINES *****
PINBL: .SPICLR,,XC-1 ;SUSET WORD TO ENABLE INTERRUPTS
PIHOLD: .SPICLR,,R70 ;SUSET WORD TO GAG INTERRUPTS
INT0: EXCH A,INT ;BIG DISPATCH !!!
JUMPL A,INT4
TRZE A,IB.TTY ;1
JRST TTYINT
INT1: TLNN A,(IB.TIMR) ;100000,,0
TLNE A,(IB.ALARM) ;200000,,0
JRST TIMOUT
TRZE A,IB.PDLO ;200000
JRST PDLOV
TRZE A,IB.IOC ;400
JRST IOERR
INT2: TRZE A,IB.ILOP ;I ASSUME THAT THERE WILL NEVER BE ANY
JRST ERRILO ;TWO OF THESE INTERRUPTS TOGETHER -
TLZE A,(IB.PUR) ; ILGL OPERATION, PURE PAGE TRAP, OR
JRST PURPGI ; ILGL MEM REFERENCE, PARITY ERROR
TRZE A,IB.MPV ;20000
JRST INT3
TLZE A,(IB.PARITY)
JRST PARERR
INT4: SKIPN UPIINT
NOINT: .VALUE
JRST @UPIINT
INT3: HRRZ A,IPCLOK
CAIN A,UBD1 ;ALLOW SPDL RESTORATION TO TAKE PLACE
JRST INTEX1 ;EVEN IF ONE SLOT IS CLOBBERED
JRST INTILM
TTYINT: MOVEM A,INTSV
MOVEI A,TYIC
.ITYIC A,
JRST INTEX
JSR CNTROL
INTEX: SKIPE A,INTSV
JRST INT1
INTEX1: MOVE A,INT
.DISMIS IPCLOK
CN.Z: .RESET TYIC, ;SO SUPERIOR WON'T SEE ↑Z AS INPUT
.VALUE [ASCII \:VK \]
JRST 2,@CNTROL
;;; IFN ITS
TIMOUT: MOVEM A,INTSV
SKIPN VALARMCLOCK ;INT FROM FRUSTRATED ALARMCLOCK
JRST TIMO1
MOVEI A,INTEX
MOVEM A,CNTROL ;THIS IS A HACK
MOVE A,INTSV
TLZN A,(IB.ALARM)
JRST TIMO6
MOVEM A,INTSV
MOVSI A,400000 ;REAL TIME INT, SO SHUT OFF CLOCK
.REALT A,
SKIPA A,[QTIME,,3]
TIMO3: MOVE A,[Q$RUNTIME,,3]
SKIPL UNREAL ;MAYBE CLOCK INTS AREN'T PERMITTED NOW
JRST UINT1
MOVSS A ;IF SO, QUEUE IT UP
MOVSM A,UNRRUN-Q$RUNTIME(A)
JRST INTEX
TIMO6: TLZN A,(IB.TIMR)
JRST INTEX ;????
MOVEM A,INTSV
JRST TIMO3
TIMO1: TLNN A,(IB.ALARM)
JRST TIMO7
MOVSI A,400000
.REALT A,
MOVE A,INTSV
TIMO7: TLZ A,(IB.TIMR+IB.ALARM) ;NO ALARM FNCTION, SO FLUSH INTERRUPTS
JUMPN A,INT1
JRST INTEX1
] ;END OF IFN ITS
;;; IFE QIO
IFN D10,[
;;; DECSYSTEM-10 INTERRUPT ROUTINES
INT0: PIOF
MOVEM A,INT ;SAVE REG A
MOVE A,.JBCNI"
TRZE A,IB.PDLOV ;PDL OVERFLOW?
JRST PDLOV ;YEP
TRZE A,IB.MPV ;ILL MEM REF?
JRST INTILM
NOINT: HALT ;I DONT KNOW WHAT THIS IS!
TTYINT: AOSLE UPCOK
JRST 2,@.JBOPC"
MOVEM A,INT
MOVE A,.JBOPC"
MOVEM A,IPCLOK
TTYIN0: SA% OUTSTR [ASCIZ \ππ?↑\]
IFN SAIL,[
SETO A,
CALLI A,400111
OUTSTR [ASCIZ \?↑\] ;FOO ON SAIL CHARACTER SET
] ;END OF IFN SAIL
INCHRW A
SA$ TRZE A,600
SA$ TRZ A,100
SETZM UPCOK
JSR CNTROL
SKIPLE UPCOK
JRST TTYIN0
MOVE A,INT
SETOM UPCOK
JRST 2,@IPCLOK
UPCHK: SKIPLE UPCOK
JRST .+3
SETOM UPCOK
POPJ P,
SETZM UPCOK
MOVEM A,INT
POP P,IPCLOK
JRST TTYIN0
JCLSET: SETZ D,
MOVE R,[440700,,SJCLBUF+1]
TTCALL 10,1
SA$ SKIPN A
SA% JRST JCST4
JRST JCST3
JCST4: INCHRS A
JRST JCST3
CAIE A,↑M ;IF <CR> OR <ALT> OCCURS ON COMMAND
CAIN A,33
JRST JCST3 ;BEFORE A ";", THEN NO JCL
CAIE A,";
JRST JCST4 ;LOOP UNTIL WE FIND A ;
MOVNI D,BYTSWD*LSJCLBUF
JCST2: INCHRS A
JRST JCST1
AOSG D
IDPB A,R
CAIN A,↑M ;<CR> OR <ALT> TERMINATES
JRST JCST1 ;THE COMMAND LINE
CAIE A,33
JRST JCST2
JCST1: SKIPLE D
TDZA D,D
ADDI D,BYTSWD*LSJCLBUF
JCST3: INCHRS A ;MAKE SURE NO SUPERFLUOUS CHAR
JFCL
MOVEM D,SJCLBUF
SETZ A,
IDPB A,R ;INSURE AT LEAST ONE NUL BYTE FOLLOWING THE LINE
JRST (F)
CN.Z: SKIPE A,.JBDDT" ;RETURN TO DDT IF IT EXISTS
JRST (A)
EXIT 1, ;OTHERWISE CRAP OUT TO MONITOR
ALTP: JRST 2,@CNTROL ;WHEN IN DDT, "ALTP$G" IS GOOD
] ;END OF IFN D10
] ;END OF IFE QIO
IFN SAIL,[
SAILINT:IMSKCL SAINTER ;UNMASK
UWAIT ;WAIT FOR UUOS TO FINISH
DEBREAK ;INTERRUPT LEVEL BECOMES USER LEVEL
MOVEM TT,ATTSV ;SAVE TT
MOVE TT,SAILJOB+1
MOVEM TT,SAICONT ;CONTINUE ADDRESS IN RIGHT PLACE
CLKINT 0 ;DISABLE
SETZ TT,
RUNTIME TT, ;WHAT TIME IS IT?
CAMGE TT,SAIALK
JRST SADISMIS ;FOO. NOT LONG ENOUGH
SAHACKIT: SKIPN VALARM
JRST SADISMIS
MOVE TT,ATTSV ;PUT BACK TT
MOVEM A,AINT ;DO IT
HRLZ A,ALCKTYP
HRRI A,3
SKIPN UNREAL
JRST S2RUN
MOVSS A
MOVSM A,UNRRUN-Q$RUNTIME(A)
SADMS0: MOVE A,AINT
SADISMIS: MOVE TT,ATTSV
CLKINT 36 ;ENABLE
INTUUO 0,SAINTER ;MASK ON & RETURN
S2RUN: JSR INTWAIT
JRST .+2
JRST SADMS0
PUSH P,AINT
PUSHJ P,UINT
JRST POPAJ
S2ILIN2:IMSKCL SAINTER
UWAIT
DEBREAK
MOVEM TT,ATTSV
MOVE TT,SAILJOB+1
MOVEM TT,SAICONT
CLKINT 0
SOSLE SAIALK ;TIME YET?
JRST .+2 ;NO
JRST SAHACKIT ;SURE
MOVE TT,ATTSV
CLKINT 12
INTUUO 0,SAINTER
] ;END OF IFN SAIL
IFN QIO,[
;;; NEW-STYLE INTERRUPT TRANSFER VECTOR
ITSMSK=%PI<PAR+WRO+MPV+ILO+PDL+IOC+RUN+RLT> ;STANDARD .MASK
IFN USELESS, ITSMSK=ITSMSK+%PI<CLI+DWN+DBG+ATY>
DBGMSK=ITSMSK-<%PI<PAR+MPV+ILO>> ;DEBUGGING .MASK
.SEE INTMSK
ITSMS2==177777 ;STANDARD .MSK2
IFN JOBQIO, ITSMS2==ITSMS2+<377,,>
DBGMS2==ITSMS2 ;DEBUGGING .MSK2
.SEE INTMS2
DEFINE INTGRP HANDLER+PIRQC=0,IFPIR=0,DF1=ITSMSK-<%PI<PDL+PAR+WRO+MPV+ILO>>,DF2=ITSMS2
PIRQC
IFPIR
DF1
DF2
HANDLER
TERMIN
INTVEC: F←6+1,,INTPDL ;PDL FOR PUSHING INTERRUPT STUFF
;AC F IS SAVED ALONG WITH OTHER CRUD
INTGRP MEMERR,PIRQC=%PI<PAR+WRO+MPV+ILO>,DF1=ITSMSK-%PI<PDL> ;MEMORY AND OPCODE ERRORS
INTGRP PDLOV,PIRQC=%PI<PDL> ;PDL OVERFLOW
INTGRP IOCERR,PIRQC=%PI<IOC> ;I/O CHANNEL ERROR
IFN USELESS, INTGRP CLIINT,PIRQC=%PI<CLI> ;CLI INTERRUPT
IFN USELESS, INTGRP TTRINT,PIRQC=%PI<ATY> ;TTY RETURNED TO JOB
IFN USELESS, INTGRP SYSINT,PIRQC=%PI<DWN+DBG> ;SYS DOWN OR DEBUGGED
IFN JOBQIO, INTGRP JOBINT,IFPIR=[377,,] ;INFERIOR PROCEDURES
INTGRP CHNINT,IFPIR=177777 ;I/O CHANNEL INTERRUPTS
TTYDF1==.-2 .SEE UINT0
TTYDF2==.-1
IFN USELESS, INTGRP MARINT,PIRQC=%PI<MAR> ;MAR BREAK
INTGRP RUNCLOCK,PIRQC=%PI<RUN> ;RUNTIME ALARMCLOCK
INTGRP REALCLOCK,PIRQC=%PI<RLT> ;REAL TIME ALARMCLOCK
LINTVEC==.-INTVEC ;LENGTH OF INTERRUPT VECTOR
;;; NOTE THE EFFECT OF HAVING THE ALARMCLOCKS LAST:
;;; IOC AND CHANNEL INTERRUPT HAPPEN FIRST, BUT WHEN
;;; THE PION HAPPENS INSIDE UINT0 THE ALARMCLOCK GETS
;;; ITS TURN IMMEDIATELY. FURTHERMORE, THE REAL TIME
;;; CLOCK GETS SLIGHTLY HIGHER PRECEDENCE.
;;; IFN QIO
;;; WHEN THE INTERRUPT OCCURS, AC F HAS BEEN SAVED.
;;; BY CONVENTION AN INTERRUPT HANDLER GETS THE INTPDL POINTER IN F.
;;; ALSO BY CONVENTION, R IS EXCHANGED WITH THE FIRST WORD
;;; INTERRUPT BITS AND D IS EXCHANGED WITH THE SECOND WORD
;;; INTERRUPT BITS WHICH ARE ON THE INTPDL.
;;; STANDARD INTERRUPT EXIT
;;; WILL RESTORE FXP AND D+R+F, AND DISMISS THE INTERRUPT.
INTXIT: POP FXP,FXP
MOVE D,IPSWD2(F) ;D WAS EXCH'D WITH SECOND WORD INT BITS
MOVE R,IPSWD1(F) ;R WAS EXCH'D WITH FIRST WORD INT BITS
.CALL INTXT9 ;RETURN PC IS ON TOP OF INTPDL,
.VALUE ; AND ALSO THE OLD DEFER WORDS
INTXT9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,F←6+1 ;POP AC F FIRST
400000,,INTPDL ;INTERRUPT STACK POINTER
;;; STANDARD LOSING INTERRUPT EXIT
;;; RESTORES FXP, AND D+R+F AS INTXIT DOES.
;;; ALSO EXPECTS A .LOSE ERROR CODE IN R.
INTLOS: POP FXP,FXP
MOVE D,IPSWD2(F)
INTLS1: EXCH R,IPSWD1(F)
.CALL INTLS9
.VALUE
INTLS9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,F←6+1 ;POP AC FFIRST
,,INTPDL ;INTERRUPT STACK POINTER
,,IPSPC(F) ;NEW PC ;IN ORDER TO SPECIFY
,,IPSDF1(F) ;NEW .DF1 ; THE .LOSE CODE, ONE
,,IPSDF2(F) ;NEW .DF2 ; MUST MENTION ALL THIS TOO
400000,,IPSWD1(F) ;.LOSE ERROR CODE
.SEE PION
;;; ENABLES **ALL** INTERRUPTS.
.SEE PIOF
;;; DISABLES **ALL** INTERRUPTS.
.SEE INTON
;;; INITIALLY SETS UP INTERRUPT SYSTEM.
PINBL: .SPICLR,,XC-1 ;.PICLR <- -1
.SDF1,,R70 ;.DF1 <- 0
.SDF2,,R70 ;.DF2 <- 0
PIHOLD: .SPICLR,,R70 ;.PICLR <- 0
INTNBL: .SDF1,,R70 ;.DF1 <- 0
.SDF2,,R70 ;.DF2 <- 0
INTNMS: .SMASK,,INTMSK ;.MASK <- INTMSK
.SMSK2,,INTMS2 ;.MSK2 <- INTMS2
;;; IFN QIO
;;; MEMORY AND OPCODE ERRORS: PARITY, PURE, MPV, ILOP.
;;; ASSUME NO MORE THAN ONE HAPPENS AT A TIME.
MEMERR: MOVE F,INTPDL
MOVEM D,IPSWD2(F)
EXCH R,IPSWD1(F)
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
HRRZ D,IPSPC(F)
CAIN D,THIRTY+5 ;DDT DOES ≠X IN LOCATION 34
JRST $XLOSE
TLNE R,(%PI<PAR>) ;WAS IT A PARITY ERROR?
JRST PARERR
TLNE R,(%PI<WRO>) ;WRITE INTO READ-ONLY?
JRST PURPGI
TRNE R,%PI<ILO> ;ILLEGAL OPERATION?
JRST ILOPER
TRNN R,%PI<MPV> ;MEMORY PROTECT VIOLATION?
.VALUE ;NO??? WHAT HAPPENED???
CAIE D,UBD1 ;LET SPECPDL RESTORATION HAPPEN
JRST MPVERR ; EVEN IF ONE SLOT GOT CLOBBERED
AOS IPSPC(F) ;BUMP PC PAST OFFENDING INSTRUCTION
JRST INTXIT
MPVERR: SKIPA D,[UIMMPV]
PURERR: MOVEI D,UIMWRO
JRST MEMER5
ILOPER: SKIPA D,[UIMILO]
PARERR: MOVEI D,UIMPAR
MEMER5: HRRZ R,IPSPC(F) ;MACHINE ERROR! WHAT TO DO?
SKIPN VMERR ;IF USER SUPPLIED NO ERROR FUNCTION,
JRST MEMER7 ; CRAP OUT BACK TO DDT
MOVEI D,100000(D)
HRLI D,(R)
PUSHJ FXP,IWAIT
PUSHJ P,UINT
JRST INTXIT ;MAY RE-DO LOSING INSTR, BUT SO WHAT?
; THAT'S A FEATURE, NOT A BUG.
MEMER7: HRRZ R,MEMER8(D)
JRST INTLOS
MEMER8:
OFFSET -.
UIMPAR:: 1+.LZ %PIPAR
UIMILO:: 1+.LZ %PIILO
UIMWRO:: 1+.LZ %PIWRO
UIMMPV:: 1+.LZ %PIMPV
OFFSET 0
$XLOST: .VALUE [ASCIZ \:≠ YOUR ≠↔≠⊗X LOST ≠↔PROCEED⊗ \]
JRST THIRTY+5 ;LET THE ≠X RETURN CORRECTLY
$XLOSE: MOVEI R,$XLOST ;CAUSE INTERRUPT DURING AN ≠X
MOVEM R,IPSPC(F) ; TO GO TO $XLOST (CROCK)
JRST INTXIT
;;; IFN QIO
;;; I/O CHANNEL ERROR HANDLER
IOCERR: MOVE F,INTPDL
MOVEM D,IPSWD2(F)
MOVEM R,IPSWD1(F)
MOVE R,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,R
.SUSET [.RBCHN,,R]
SKIPN R
JRST IOCER8
.CALL SCSTAT
.LOSE 1400
LSH D,-33
HRRZ R,IPSPC(F)
MACROLOOP NIOCTR,ZZI,* ;ZZI MACROS DEFINE IOC TRAPS
SKIPL R
JRST IOCER8
HRRM R,IPSPC(F) ;CLOBBER RETURN PC
HLRZ R,R
CAIN R,400000+D ;WANT TO STICK IOC ERROR
MOVEI R,400000-IPSWD2(F) ; CODE INTO SPECIFIED AC,
CAIN R,400000+R ; BUT MUST BEWARE OF D AND R
MOVEI R,400000-IPSWD1(F)
MOVEM D,-400000(D)
JRST INTXIT
IOCER8: MOVEI R,1+.LZ %PIIOC
JRST INTLOS
;;; IFN QIO
; COMMENT FOR @ CHANGE
;;; INTERRUPT FROM I/O CHANNEL.
;;; PRESENTLY ONLY TWO KINDS ARE HANDLED:
;;; TTY INPUT: INTERRUPT CHAR TYPED.
;;; TTY OUTPUT: **MORE**.
CHNINT: MOVE F,INTPDL
EXCH D,IPSWD2(F) ;GET WORD TWO INTERRUPT BITS
MOVEM R,IPSWD1(F)
MOVE R,FXP ;FXP MAY BE IN A BAD STATE IF
SKIPE GCFXP ; WITHIN GC, SO RESTORE IT AND
MOVE FXP,GCFXP ; THEN PUSH ITS OLD VALUE
PUSH FXP,R ;REMEMBER, PDL OVERFLOW ISN'T DEFERRED NOW
PUSH FXP,D
CHNI1: JFFO D,.+1 ;FIND CHANNEL NUMBER
MOVNS R ; FOR SOME PENDING
ADDI R,43 ; INTERRUPT BIT
PUSH FXP,R ;SAVE CHANNEL NUMBER
SKIPE R ;CHANNEL 0 ??
SKIPN CHNTB(R) ;UNOPEN DEVICE ??
.VALUE
MOVEI D,1
LSH D,(R)
ANDCAM D,-1(FXP) ;CLEAR THE BIT
CHNI1H: .CALL SCSTAT ;GET STATUS FOR THE CHANNEL
.VALUE
ANDI D,77 ;GET ITS INTERNAL PHYSICAL DEVICE TYPE
SKIPE D
CAILE D,2
JRST CHNI5
HRRZ D,CHNTB(R)
MOVE D,TTSAR(D)
TLNE D,TTS<IO>
JRST CHNI5
.ITYIC R, ;TYPE 0 IS TTY INPUT
JRST CHNI8 ;TIMING ERROR OR SOMETHING - IGNORE
PUSH FXP,R ;SAVE INTERRUPT CHARACTER
PUSH FXP,TT ; AND ALSO TT
HRRZ TT,-2(FXP) ;FETCH CHANNEL NUMBER
HRRZ TT,CHNTB(TT)
HRRZ TT,TTSAR(TT)
JSP D,TTYICH ;GET BACK INTERRUPT FN IN R
POP FXP,TT
JUMPE R,CHNI2 ;NULL FUNCTION - IGNORE
MOVEI D,(R)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,FX
JRST CHNI4
MOVE R,(R) ;"FUNCTION" IS A FIXNUM
MOVEI D,(R) ;IF EITHER OF THE META AND
ANDCM D,(FXP) ; CONTROL BITS ARE SET IN THE
MOVSS (FXP) ; "FUNCTION", INSIST THAT THE
ANDM R,(FXP) ; CORRESPONDING BITS APPEAR IN
MOVSS (FXP) ; THE CHARACTER TYPED. SIMILARLY,
IOR D,(FXP) ; THE SAME BITS SET IN THE LEFT HALF
TRNE D,%TX<MTA+CTL> ; MEAN THAT THOSE BITS MUST BE OFF.
JRST CHNI2
ANDI R,177
MOVEI D,TRUTH ;MOOOOBY SKIP CHAIN OF SYSTEM INTS
CAIN R,↑C ;↑C (SETQ ↑D NIL)
SETZM GCGAGV
CAIN R,↑D ;↑D (SETQ ↑D T)
HRRZM D,GCGAGV
CAIN R,↑G ;↑G (↑G) ;QUIT
JRST CN.G
CAIN R,↑R ;↑R (SETQ ↑R T)
HRRZM D,TAPWRT
CAIN R,↑T ;↑T (SETQ ↑R NIL)
SETZM TAPWRT
CAIN R,↑V ;↑V (SETQ ↑W NIL)
SETZM TTYOFF
CAIN R,↑W ;↑W (PROG2 (SETQ ↑W T)
JRST CN.W ; (CLEAR-OUTPUT T))
CAIN R,↑X ;↑X (ERROR 'QUIT) ;↑X QUIT
JRST CN.X
CAIN R,↑Z ;↑Z CRAP OUT TO DDT
JRST CN.Z
CHNI2: SUB FXP,R70+2
JRST CHNI9
;;; IFN QIO
CHNI4: POP FXP,D ;REAL LIVE USER INTERRUPT FUNCTION
TRO D,400000 ;2.9 => TTY INPUT INTERRUPT CHAR
CHNI4A: POP FXP,R
HRL D,CHNTB(R)
SKIPE UNREAL
JSP R,CHNI4C ;BARF! (NOINTERRUPT 'TTY) OR (NOINTERRUPT T)
PUSHJ FXP,IWAIT ;CALLS UISTAK AND SKIPS IF IN GC
PUSHJ P,UINT ;RUNS USER INTERRUPT
JRST CHNI9
CHNI5: HRRZ D,CHNTB(R) ;CHECK OUT FILE ARRAY
HRRZ D,TTSAR(D)
SKIPN FO.EOP(D) ;SKIP IF ENDPAGEFN
JRST CHNI8
MOVEI D,200000+<2*FO.EOP+1> ;2.8 => RANDOM FILE INTERRUPT
JRST CHNI4A ;**MORE** => ENDPAGEFN GETS RUN
CHNI8: SUB FXP,R70+1
CHNI9: SKIPE D,(FXP)
JRST CHNI1
CHNI9A: SUB FXP,R70+1 ;COME HERE FROM JOBI8
JRST INTXIT
;;; ROUTINE TO STACK UP INTERRUPT IN INTAR -- USED BY CHNINT, JOBINT, AND FNYINT
CHNI4C: MOVE F,UNREAR ;STACK UP INTERRUPT IN THE
CAIL F,LUNREAR ; NOINTERRUPT QUEUE
JRST TMDAMI ;OOPS! TOO MANY DAMN INTERRUPTS!
MOVE F,[400000+LUNREAR-1,,UNREAR+LUNREAR-2]
CHNI4H: POP F,1(F)
TLNE F,377777
JRST CHNI4H
MOVEM D,UNREAR+1
AOS UNREAR
HRRZ F,INTPDL
JRST 2(R)
;;; IFN QIO
; COMMENT FOR @ CHANGE
IFN JOBQIO,[
;;; INTERRUPT FROM INFERIOR PROCEDURE(S)
JOBINT: MOVE F,INTPDL
EXCH D,IPSWD2(F)
MOVEM R,IPSWD1(F)
MOVE R,FXP
SKIPE GCFXP ;IF IN GC, FXP MAY BE
MOVE FXP,GCFXP ; SCREWED UP
PUSH FXP,R
PUSH FXP,D ;WORD OF INTERRUPT BITS
JOBI1: JFFO D,.+1
MOVNS R ;-22 < R < -11
MOVSI D,1
LSH D,21(R)
ANDCAM D,(FXP) ;CLEAR BIT
SKIPN D,JOBTB+21(R)
.VALUE ;NO JOB ARRAY???
HRRZ R,TTSAR(D)
SKIPN J.INTF(R)
JRST JOBI8 ;NO INTERRUPT FUNCTION - IGNORE INTERRUPT
MOVSI D,(D)
TRO D,200000+<2*J.INTF+1>
SKIPGE UNREAL
JSP R,CHNI4C ;GORP! (NOINTERRUPT T)
PUSHJ FXP,IWAIT
PUSHJ P,UINT
JOBI8: SKIPE D,(FXP)
JRST JOBI1 ;MORE INFERIOR INTERRUPTS
JRST CHNI9A ;ALL DONE
] ;END OF IFN JOBINT
;;; IFN QIO
;;; TTSAR OF TTY INPUT FILE ARRAY IN TT.
;;; INPUT INTERRUPT CHARACTER IN R.
;;; RETURN ADDRESS IN D.
;;; RETURNS INTERRUPT FUNCTION IN R.
TTYICH: TRZ R,%TX<TOP+SFL+SFT+MTA> ;FOLD 12.-BIT CHAR
TRZN R,%TX<CTL> ; DOWN TO 7 IF NECESSARY
JRST TTYIC1
CAIE R,177
TRZ R,140
TTYIC1: ROT R,-1 ;CLEVER ARRAY ACCESS
ADDI TT,FB.BUF(R) ;INTERRUPT FNS ARE IN "BUFFER"
HLR R,(TT)
SKIPGE R
HRRZ R,(TT) ;SIGN BIT OF R GETS CLEARED
JRST (D)
;;; VARIOUS SYSTEM TTY INPUT CHAR INTERRUPT HANDLERS.
CN.W: HRRZM D,TTYOFF ;IMMEDIATE TTYOFF (↑W)
PUSH FXP,T
PUSH FXP,TT
HRRZ TT,V%TYO
MOVE TT,TTSAR(TT)
PUSHJ FXP,CLRO3 ;ALSO DO (CLEAR-OUTPUT T)
POP FXP,TT
POP FXP,T
JRST CHNI2
CN.Z: .CALL CKI2I ;***** CROCK *****
.VALUE
.VALUE [ASCIZ \:≠DDT≠
\]
JRST CHNI2
CTRLG: HRROI D,-3 ;↑G - SUBR 0
PIOF
JRST CN.G0
CN.X: SKIPA D,[-6] ;ERRSETABLE (↑X) QUIT
CN.G: HRROI D,-7 ;IMMEDIATE (↑G) QUIT
CN.G0: SKIPE UNREAL
JRST CN.G1
CN.G5: SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP
HRREM D,INTFLG
PUSHJ FXP,IWAIT
PUSHJ P,CHECKI
JRST CHNI2
CN.G1: SETZM UNREAR ;KILL STACKED UNREAL INTERRUPTS
CAMN D,XC-3
JRST CN.G5 ;JUMP IF ↑G SUBR
EXCH D,UNRC.G ;ELSE STACK UP AN UNREAL
TRNE D,1 ; ↑G OR ↑X INTERRUPT
MOVEM D,UNRC.G
JRST CHNI2
;;; IFN QIO
;;; REAL TIME ALARMCLOCK
REALCLOCK:
MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVSI R,400000 ;SHUT CLOCK BACK OFF
.REALT R,
MOVEI R,QTIME
JRST RCLOK1
;;; RUNTIME ALARMCLOCK
RUNCLOCK:
MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVEI R,Q$RUNTIME
RCLOK1: MOVEM D,IPSWD2(F)
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
SKIPN VALARMCLOCK ;IGNORE IF THERE IS NO
JRST INTXIT ; ALARMCLOCK FUNCTION
MOVSI D,(R) ;TYPE 0, SUBTYPE 0 IS ALARMCLOCK
SKIPL UNREAL ;SKIP IF (NOINTERRUPT T)
JRST RCLOK2
MOVEM D,UNRRUN-Q$RUNTIME(R) ;STACK UP INTERRUPT
JRST INTXIT
IFN USELESS,[
FNYINT: MOVEM D,IPSWD2(F) ;COMMON HANDLER FOR FUNNY INTERRUPTS
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
MOVE R,(R)
SKIPN (R)
JRST INTXIT ;EXIT IF NO USER HANDLER
HLRZ D,R
SKIPGE UNREAL
JSP R,CHNI4C ;MUST STACK UP IF UNREAL
] ;END OF IFN USELESS
RCLOK2: PUSHJ FXP,IWAIT ;WILL STACK AND SKIP IF GC
PUSHJ P,UINT ;GIVE USER CLOCK INTERRUPT
JRST INTXIT
;;; IFN QIO
IFN USELESS,[
;;; CLI INTERRUPT HANDLER
CLIINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFCLI,,VCLI
;;; MAR BREAK
MARINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
MOVEI R,%PI<MAR>
ANDCAM R,INTMSK
.SUSET INTNMS
.SUSET [.SMARA,,R70]
MOVEI R,1+.LZ %PIMAR
SKIPN VMAR
JRST INTLS1 ;IN CASE (STATUS MAR) GETS LOUSED UP
JSP R,FNYINT
UIFMAR,,VMAR
;;; RETURN OF TTY TO THE JOB
TTRINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFTTR,,VTTR
;;; SYSTEM GOING DOWN OR BEING DEBUGGED
SYSINT: MOVE F,INTPDL
MOVEM R,IPSWD1(F)
JSP R,FNYINT
UIFSYS,,VSYSD
] ;END OF IFN USELESS
;;; IFN QIO
;;; STACK UP A USER INTERRUPT WHICH MUST BE DELAYED.
;;; ARGUMENT IS IN D AS FOR UINT; IT IS SAVED IN THE INTAR QUEUE.
;;; ASSUMES FREE USE OF ACCUMULATOR R.
;;; PI INTERRUPTS MUST BE DISABLED!!!!
.SEE PIOF
YESIN1: POP P,UISTAK ;THIS IS A HORRIBLE CROCK
;UISTAK: 0
UISTK1: MOVE R,INTFLG ;IF WE ARE ABOUT TO QUIT ANYWAY,
AOJL R,@UISTAK ; THEN FORGET THE WHOLE THING
AOS R,INTAR
CAILE R,LINTAR
JRST TMDAMI ;TOO MANY DAMN INTERRUPTS
MOVE R,[400000+LINTAR-1,,INTAR+LINTAR-2]
UISTK2: POP R,1(R)
TLNE R,377777
JRST UISTK2
MOVSM D,INTAR+1
SETOM INTFLG
JRST @UISTAK
TMDAMI: SKIPN GCFXP ;TOO MANY DAMN INTERRUPTS
LERR EMS12
IRP X,,[P,FLP,FXP,SP]
MOVE X,GC!X
TERMIN
LERR EMS12
] ;END OF IFN QIO
IFE D10,[
IFE QIO,[
;;; PURE PAGE TRAP HANDLER
PURPGI: MOVEM A,INTSV ;TRIED TO WRITE INTO A PURE PAGE
HRRZ A,IPCLOK
CAIN A,STQPUR+1
JRST PPGI5
MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
JUMPGE A,PPGI2
PPGI3: HRRM A,IPCLOK
JRST INTEX
PPGI2: MOVEI A,4 ;LOSE LOSE - A BAD ERROR
JRST PPGI4
PPGI5: EXCH A,INT ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
MOVEM A,STQLUZ
MOVE A,[TIRPATE,,NIL]
MOVEM A,(SP)
MOVE A,STQLUZ
EXCH A,INT
JSR INTWAIT ;LET SPDL GET CAUGHT UP, IF LAMBDA OR SET BINDING
SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T
JRST PPGI2 ;IN CASE INTWAIT SKIPS
PPGI6: HRRZI A,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL
JRST PPGI3
; ENDCODE [PURPGI]
] ;END OF IFE QIO
IFN QIO,[
; PUTCODE [QIO PURPGI]\20+2*NPURTR,INT,GC
;;; PURE PAGE TRAP HANDLER
;;; COMES HERE WITH LOSING PC IN D.
.SEE MEMERR
PURPGI: CAIN D,STQPUR
JRST PPGI5
MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
JUMPGE D,PURERR
PPGI3: HRRM D,IPSPC(F)
JRST INTXIT
PPGI5: MOVEM A,STQLUZ ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
MOVE D,[TIRPATE,,NIL]
MOVEM D,(SP)
SKIPE GCFXP
.VALUE
AOS IPSPC(F) ;DON'T RETRY THE LOSING INSTRUCTION!
PUSHJ FXP,IWAIT ;LET SPDL GET CAUGHT UP
SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T
JRST PURERR ;INTWAIT MAY SKIP
PPGI6: HRRZI D,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL
JRST PPGI3
; ENDCODE [QIO PURPGI]
] ;END OF IFN QIO
] ;END OF IFE D10
SUBTTL USER INTERRUPT ROUTINES
;;; USER INTERRUPT TYPES FOR NEWIO
;;;
;;; FORM OF ARGUMENT TO UINT (ALSO STORED IN THIS FORM
;;; IN INTAR, ONLY WITH HALVES SWAPPED; WHY, I DON'T KNOW):
;;;
;;; 4.9-3.1 ARGUMENT FOR INTERRUPT FUNCTION
;;; 2.9 IF 1, SPECIFIES A TTY INPUT CHARACTER INTERRUPT.
;;; ARGUMENT IS TTY INPUT FILE ARRAY.
;;; 2.8-2.4 MUST BE ZERO.
;;; 2.3-1.1 CHARACTER WHICH CAUSED INTERRUPT, AS
;;; READ BY .ITYIC. THIS MAY BE A 12.-BIT
;;; CHARACTER, AND SO MAY HAVE TO BE FOLDED
;;; BEFORE SELECTING THE INTERRUPT FUNCTION.
;;; THIS IS PASSED AS THE SECOND ARGUMENT.
;;; 2.8 IF 1, SPECIFIES AN INTERRUPT RELATED TO A FILE
;;; ARRAY OR SIMILAR OBJECT, E.G. THE **MORE**
;;; INTERRUPT FOR TTY OUTPUT.
;;; ARGUMENT IS THE FILE ARRAY.
;;; 2.7-1.1 IS THE INDEX OF THE INTERRUPT FUNCTION
;;; WITHIN THE ARRAY, WHERE THE LOW BIT SPECIFIES
;;; LEFT OR RIGHT HALF AS USUAL.
;;; 2.7 IF 1, SPECIFIES A MACHINE ERROR.
;;; THE ARGUMENT IS THE LOCATION OF THE LOSS.
;;; BITS 1.9-1.1 SPECIFY THE NATURE OF THE ERROR.
UIMPAR==:0 ;ODDP ;PARITY ERROR
UIMILO==:1 ;EVAL ;ILLEGAL OPERATION
UIMWRO==:2 ;DEPOSIT ;WRITE INTO READ-ONLY MEMORY
UIMMPV==:3 ;EXAMINE ;MEMORY PROTECT VIOLATION
;;; IF 2.9-2.7 ARE ZERO, THEN:
;;; 2.2-2.1 TYPE OF INTERRUPT
;;; 1.9-1.1 SPECIFIC INTERRUPT
;;; CURRENT TYPES AND SPECIFIC INTERRUPTS ARE:
;;; 0 RANDOM ASYNCHRONOUS (DELAYED BY (NOINTERRUPT T))
;;; 0 ALARMCLOCK
UIFCLI==:1 ;CLI-MESSAGE ;USELESS
UIFMAR==:2 ;MAR-BREAK ;USELESS
UIFTTR==:3 ;TTY-RETURN ;USELESS
UIFSYS==:4 ;SYS-DEATH ;USELESS
IFE USELESS, NUINT0==:1 .SEE GCP6Q6
IFN USELESS, NUINT0==:5 .SEE GCP6Q6
;;; 1 RANDOM SYNCHRONOUS
;;; 0 AUTOLOAD
;;; 1 ERRSET FN
;;; 2 *RSET-TRAP
;;; 3 GC-DAEMON
;;; 4 GC-OVERFLOW
;;; 5 PDL-OVERFLOW
NUINT1==:6 .SEE GCP6Q6
;;; 2 ERINT (SYNCHRONOUS)
;;; 0 UNDF-FNCTN
;;; 1 UNBND-VRBL
;;; 2 WRNG-TYPE-ARG
;;; 3 UNSEEN-GO-TAG
;;; 4 WRNG-NO-ARGS
;;; 5 GC-LOSSAGE
;;; 6 FAIL-ACT
;;; 7 IO-LOSSAGE
NUINT2==:10 .SEE GCP6Q6
UINT:
Q% SKIPN @UINTTB(A) ;SERVICE USER INTERRUPT
Q% JRST FALSE ;WE DONT PUSHJ HERE FROM PI LEVEL, UNLESS WE KNOW
PUSHJ P,UINTPU ;THAT GC IS NOT IN PROGRESS [THUS WE HAVE A PDL]
SKIPN NOQUIT
SKIPE INHIBIT
JRST UINT2
SKIPGE INTFLG
JRST UINT3
PUSHJ P,UINT0
UINTEX: SKIPL (FXP) ;PEOPLE COME HERE TO UNDO UINTPU
JRST UINTX1
PION
UINTX1: SUB FXP,R70+1
Q$ POP FXP,R .SEE UINTPU
JRST CHECKI ;PDL-OVERFLOW MAY HAVE BEEN STACKED
Q% .SEE PDLHAK
Q$ .SEE PDLOV
UINT2: JSR UISTAK ;DELAY A USER INTERRUPT, SINCE INHIBIT SWITCH IS ON
JRST UINTEX
UINT3: HRRZ D,INTFLG ;CHECK INTERRUPT FLAG TO SEE THAT IS SAYS "QUIT"
CAIE D,-1 ;AND NOT SOME INCONCRUOUS USER PI
JRST CKI2
HHCTB: .VALUE
; LERR EMS11 ;HOW THE HELL CAN THIS BE?
UINTPU: ;PUSH PI STATE, THEN DISABLE
IFN ITS,[
Q$ PUSH FXP,R ;SAVE R FOR UISTAK, ETC.
PUSH FXP,T
.SUSET [.RPICLR,,T]
EXCH T,(FXP)
SKIPGE (FXP)
.SUSET PIHOLD
] ;END OF IFN ITS
10$ PUSH FXP,UPCOK
10$ SETZM UPCOK
POPJ P,
IFE QIO,[
YESIN1: POP P,UISTAK ;CROCK, CROCK, CROCK!!!
;UISTAK: 0
UISTK1: AOSGE INTFLG ;DONT WORRY, INTERRUPTS ARE SHUT OFF
JRST UINT4 ;USES QITD AND QITR, BUT NOT QITC
SETZM INTFLG
MOVEM D,QITD
MOVEM R,QITR ;STACK UP AN INTERRUPT IN THE DELAYED INTERRUPT ARRAY
AOS R,INTAR ;BECAUSE USER INTERRUPTS ARE NOT NOW ENABLED
CAILE R,LINTAR
LERR EMS12 ;TOO MANY INTERRUPTIONS
JRST UISTK3
UISTK2: MOVE D,INTAR(R)
MOVEM D,INTAR+1(R)
UISTK3: SOJG R,UISTK2
MOVSM A,INTAR+1
MOVE R,QITR
MOVE D,QITD
UINT4: SOS INTFLG
MOVEI A,0
JRST 2,@UISTAK
] ;END OF IFE QIO
IFE QIO,[
;;; SAVE WORLD - INCLUDES STATE OF PICL, VALUES OF ACCS 2 THRU 13
;;; AND MOST WRITABLE SYSTEM TEMPS. THEN RUN THE ASSOCIATED ROUTINE.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
YESINT: SKIPN NOQUIT
SKIPE INHIBIT
JRST YESIN1
UINT0: HRRZS (P)
SKIPGE UINTTB(A)
HRROS (P)
HRR A,@UINTTB(A) ;ARG IN LH, TABLE INDEX IN RH CONVERTED INTO INT FUN
PUSH P,A
UINT26: HLRZ A,P
CAIL A,LUINF
10% JRST UINT27
UINT42: HLRZ A,FXP
CAIL A,-<LSWS+6>
10$ JRST XPOV
.ELSE,[
JRST UINT43
UINT55: HLRZ A,SP
CAIL A,-4
JRST UINT56
] ;END OF .ELSE
PUSH FXP,UNREAL
SKIPGE -1(P)
SETOM UNREAL
ADD FXP,[LSWS+5,,LSWS+5]
PUSH P,[$UIFRAME]
PUSH P,FXP ;SAVE PDLS SO THAT IF FRETURN WANTS TO BREAK OUT
HRLM FLP,(P) ;OF A USER INTERRUPT, HE CAN DO SO CORRECTLY
PUSHJ FXP,SAV5M1
PUSH P,40 ;SAVE INTERPRETED ACS AND STUFF ON PDL TO GC PROTECT IT
LUINF==-<NACS-1>-1-2 ;LOCATION OF USER INTERRUPT FUNCTION ON PDL - WHERE A WENT
MOVEI A,-<LSWS+5>+1(FXP)
HRLI A,T
BLT A,-LSWS(FXP) ;SAVE NON-INTERPRETED ACS
MOVEI A,-<LSWS>+1(FXP)
HRLI A,SWS
BLT A,(FXP) ;SAVE SUPER-WRITABLE STUFF
JSP T,SPECBIND
0 NIL,TYIMAN ;EVIL VILLIANS, WE BIND TYI-MAN
0 NIL,TMBBC ; AND FORCE HIM TO DO OUR WILL!
0 NIL,LISAR
SETZM INTSV
SETZM PA4
IFN USELESS, SETZM TYOSW
SETZM INHIBIT
SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS TO
SETOM RRDF ; THROW THROUGH USER INTERRUPTS
SETOM ERRSW
MOVEI A,LUINF+1(P)
MOVEM A,UIRTN
HLRZ A,LUINF(P)
HRRZS LUINF(P)
PION
CALLF 1,@LUINF(P) ;APPLY INTERRRUPT FUNCTION
;FALLS THROUGH
;FALLS IN
;;; IFE QIO
PIOF
MOVEM A,LUINF(P) ;SETUP FOR RETURN VALUE
PUSHJ P,UNBIND ;RESTORE TYIMAN ETC.
UINT0X: HRLI A,-<LSWS+5>+1(FXP) ;RESTORE WORLD
HRRI A,T
BLT A,T+4
HRLI A,-<LSWS>+1(FXP)
HRRI A,SWS
BLT A,SWS+LSWS-1
SUB FXP,[LSWS+5,,LSWS+5]
POP P,40
PUSHJ FXP,RST5M1
SUB P,R70+2 ;KNOCK OFF PDLS AND UIFRAME MARKER
POP FXP,A ;OLD STATE OF UNREAL
SKIPL -1(P) ;IF INTERRUPT TABLE DIDN'T HAVE BIT 4.9
JRST POPAJ ; ON, MUSTN'T ATTEMPT TO RESTORE UNREAL
EXCH A,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON
JUMPE A,POPAJ ; JUST NOW? IF NOT, RETURN.
SKIPE UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT?
JRST UINT0Z ;NO, IT'S STILL ON - RETURN.
UINT0N: HRRZ A,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME?
CAIL A,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY
JRST UINT0Q ; RECURSIVE CALLS.
CAIL A,NOINTERRUPT
JRST POPAJ
UINT0Q: PUSH FXP,F ;WELL, WE NEED TO RUN ANY DELAYED INTERRUPTS
SKIPE UNREAL
JRST UINT0Y
PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU
UINT0V: POP FXP,F
JRST POPAJ
UINT0Y: PUSHJ P,CHECKZ ;HACKISH ENTRY INTO CHECKU
JRST UINT0V
UINT0Z: SKIPG UNREAL
JRST POPAJ
JUMPG A,POPAJ
JRST UINT0N
IFN ITS,[
UINT27: MOVE A,[LUINF,,P]
JSR PDLHAK
JRST UINT26
UINT43: MOVE A,[LSWS+6,,FXP]
JSR PDLHAK
JRST UINT42
UINT56: MOVE A,[4,,SP]
JSR PDLHAK
JRST UINT55
] ;END OF IFN ITS
] ;END OF IFE QIO
IFN QIO,[
;;; SAVE THE WORLD FOR A USER INTERRUPT, INVOKE IT, AND RESTORE.
;;;
;;; SAVED QUANTITIES INCLUDE ALL ACCUMULATORS, THE PDL POINTERS
;;; (FOR FRETURN), AND THE SUPER-WRITABLE STUFF (TEMPORARIES IN
;;; LOW CORE USED BY INTERRUPTABLE FUNCTIONS).
;;; MANY GLOBAL SWITCHES ARE BOUND AND RESET.
;;; FOR ASYNCHRONOUS USER INTERRUPTS, THE (NOINTERRUPT T) STATE
;;; MAY BE ENTERED; THE PREVIOUS NOINTERRUPT STATE IS SAVED.
;;; MUST NOT COME HERE WITHOUT FIRST USING THE IWAIT
;;; ROUTINE TO DECIDE WHETHER OR NOT WE ARE IN GC.
;;; ALSO MUST CHECK THE NOINTERRUPT SWITCH BEFORE COMING HERE
;;; IF THAT IS RELEVANT TO THE PARTICULAR USER INTERRUPT.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
;;; THE WORD DESCRIBING THE USER INTERRUPT MUST BE IN D.
YESINT: SKIPN NOQUIT
SKIPE INHIBIT
JRST YESIN1
UINT0: .SUSET [.SDF1,,TTYDF1] ;MUST ALLOW PDL OVERFLOW TO
.SUSET [.SDF2,,TTYDF2] ; GO THROUGH, BUT NO OTHERS.
.SUSET PINBL ; ALSO LET MPV GO THROUGH.
HRRZS (P) ;WILL HRROS IF ASYNCHRONOUS
PUSHJ P,SAVX5 ;SAVE NUMERIC ACS
PUSH FXP,UNREAL
MOVSI R,-LSWS
PUSH FXP,SWS(R)
AOBJN R,.-1
JSP T,SPECBIND ;MUST SPECBIND LISAR
LISAR
SETZM PA4
IFN USELESS, SETZM TYOSW
SETZM INHIBIT
SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS
SETZM BFPRDP ; TO THROW OUT OF USER INTERRUPTS
SETOM ERRSW
MOVE T,[-LINTPDL,,INTPDL]
MOVEM T,INTPDL
REPEAT 3, PUSH FXP,R70 ;RANDOM SLOTS FOR NUMERIC ARGS;
; ; ALSO 4.9 OF TOP ONE => RETURN VALUE MATTERS
UIXPUSH==:5+1+LSWS+3 ;AMOUNT OF STUFF PUSHED ON FXP
UISWS==:-<LSWS+3>+1 ;WHERE SWS STARTS WHEN SAVED ON FXP
UISAVT==:UISWS-6 ;WHERE ACCUMULATOR T GETS SAVED
PUSH P,[$UIFRAME] ;FRAME MARKER AND PDLS SAVED
PUSH P,FXP ; SO THAT THROW AND FRETURN WIN
HRLM FLP,(P) .SEE UIBRK
PUSHJ FXP,SAV5 ;SAVE ARGUMENT ACS AND 40 ON
PUSH P,40 ; REGPDL FOR GC PROTECTION
UIFRM==-2-NACS ;LOCATION OF FRAME ON REGPDL
UISAVA==UIFRM+2 ;LOCATION OF AC A ON REGPDL
MOVEI A,UIFRM(P)
MOVEM A,UIRTN
MOVSI AR2A,(CALLF 1,)
HLRZ A,D ;GET FIRST ARG FOR INTERRUPT FN
TRZN D,400000 ;DECODE INTERRUPT TYPE
JRST UINT30
HRRZM D,(FXP) ;TTY INPUT INTERRUPT CHAR
MOVEI R,(D)
MOVE TT,TTSAR(A)
JSP D,TTYICH ;FETCH INTERRUPT FN
MOVSI AR2A,(CALLF 2,)
HRRI AR2A,(R)
MOVEI B,(FXP) ;SECOND ARG IS CHARACTER
JRST UINT31
;;; IFN QIO
UINT30: TRZN D,200000
JRST UINT32
MOVEI TT,(D) ;RANDOM FILE INTERRRUPT
ROT TT,-1
HRR AR2A,@TTSAR(A) ;FETCH INTERRUPT FUNCTION
SKIPL TT
HLR AR2A,@TTSAR(A)
UINT31: HRROS UIFRM-1(P) ;ASYNCHRONOUS INTERRUPT
JRST UINT40
UINT32: TRZN D,100000
JRST UINT33
HRRZM A,-1(FXP)
MOVEI A,QODDP(D) ;MACHINE ERROR
MOVEI B,(FXP)
MOVEI C,-1(FXP)
MOVEI AR1,-2(FXP)
MOVSI AR2A,(CALLF 4,)
HRR AR2A,VMERR
JRST UINT40
UINT33: LDB TT,[110200,,D] ;BITS 2.2-2.1 ARE CLASS
ANDI D,777 ;1.9-1.1 ARE SUBTYPE
XCT UINT90(TT) ;FETCH INTERRUPT FUNCTION
XCT UINT91(TT) ;SPECIAL HACKS
UINT40: SKIPGE UIFRM-1(P)
SETOM UNREAL
PION ;***** ENABLE INTERRUPTS *****
XCT AR2A ;APPLY INTERRUPT FUNCTION
HRRZ T,UIFRM+1(P)
CAIE T,(FXP)
PUSHJ P,UINT45
HLRZ T,UIFRM+1(P)
CAIE T,(FLP)
PUSHJ P,UINT46
PIOF ;***** DISABLE INTERRUPTS *****
SKIPGE (FXP) ;IF RETURN VALUE MATTERS
MOVEM A,UISAVA(P) ; SAVE IT FOR RETURN
PUSHJ P,UNBIND ;RESTORE LISAR, ETC.
UINT0X: HRLI R,UISWS(FXP)
HRRI R,SWS
BLT R,SWS+LSWS-1 ;RESTORE SUPER-WRITABLE STUFF
SUB FXP,[-UISWS+1,,-UISWS+1]
POP P,40
PUSHJ FXP,RST5M1
POP P,-2(P) ;KNOCK OFF PDLS AND UIFRAME, SAVING
SUB P,R70+1 ; SAVED CONTENTS OF A FOR POPAJ BELOW
POP FXP,D ;OLD STATE OF UNREAL
SKIPL -1(P) ;IF INTERRUPT WASN'T ASYNCHRONOUS,
JRST UINT88 ; MUSTN'T ATTEMPT TO RESTORE UNREAL
EXCH D,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON
JUMPE D,UINT88 ; JUST NOW? IF NOT, RETURN.
SKIPE A,UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT?
JRST UINT0Z ;NO, IT'S STILL ON - RETURN.
UINT0N: HRRZ T,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME?
CAIGE T,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY
CAIGE T,NOINTERRUPT ; RECURSIVE CALLS
PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU
JRST UINT88
UINT0Z: SKIPLE UNREAL
JUMPLE D,UINT0N
UINT88: PUSHJ P,RSTX5
10% .SUSET PINBL
JRST POPAJ
Q$ EUINT0==. .SEE PDLOV ;END OF UINT0
UINT45: SKIPA B,[QFIXNUM]
UINT46: MOVEI B,QFLONUM
EXCH A,B
PUSHJ P,UINT49
EXCH A,B
POPJ P,
UINT49: FAC [PDL OUT OF PHASE IN USER INTERRUPT (SYSTEM ERROR)!]
UINT90: HRR AR2A,VALARMCLOCK(D) ;ALARMCLOCK SERIES
HRR AR2A,VAUTFN(D) ;RANDOM SYNCHRONOUS
HRR AR2A,VUDF(D) ;ERINT SERIES
.VALUE ;??
UINT91: HRROS UIFRM-1(P) ;ALARMCLOCK (ASYNCHRONOUS)
JFCL ;RANDOM SYNCHRONOUS
SETOM (FXP) ;ERINT (VALUE MATTERS)
.VALUE ;??
] ;END OF IFN QIO
CKI0: PUSH FXP,D
HRRZ D,INTFLG
CAIN D,-1
JRST CKI1 ;DELAYED USER INTERRUPT
PIOF
CKI2: SETZM UNREAR
CKI2A: SETZM UNRC.G ;CHECKU JOINS IN AT THIS POINT
SETZM INTFLG ; RESET TTY NO RESET
TRNE D,4 ;↑X -6 -2
JRST CKI3 ;↑G -7 -3
IFN ITS,[
Q% .RESET TYIC,
Q% .RESET TYOC,
IFN QIO,[
PUSH FXP,D
MOVEI F,LCHNTB-1 ;RESET ALL TTY FILES
CKI2F: SKIPN AR1,CHNTB(F)
JRST CKI2F1
MOVE TT,TTSAR(AR1)
TLNN TT,TTS<TY>
JRST CKI2F1
MOVEI T,CLRI3
TLNE TT,TTS<IO>
MOVEI T,CLRO3
PUSHJ FXP,(T)
CKI2F1: SOJG F,CKI2F
POP FXP,D
] ;END OF IFN QIO
] ;END OF IFN ITS
10$ CLRBFO
10$ CLRBFI
Q% SETZM PBFTY
Q% SETZM RDTYBF
CKI3:
IFN ITS,[
.SUSET [.RDF1,,A]
JUMPE A,CKI3B
.SUSET [.SAMASK,,A]
.SUSET [.SDF1,,R70]
] ;END OF IFN ITS
CKI3B: TRNN D,2
SKIPE PSYMF
RQITR: LERR [SIXBIT \QUIT!\] ;SO ERROR OUT FOR ↑X
MOVE P,C2 ;DRASTIC ACTION FOR ↑G
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JSP A,ERINI0
IFN QIO*USELESS*ITS,[
MOVE T,INTMSK
TRNN T,%PI<MAR>
JRST CKI4A
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70] ;AVOID TRIPPING THE MAR DURING THE ERRPOP
CKI4A:
] ;END OF IFN QIO*USELESS*ITS
PUSHJ P,ERRPOP
IFN QIO*USELESS*ITS,[
TRNE T,%PI<MAR> ;ERRPOP PRESERVES T
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN QIO*USELESS*ITS
SETZM TTYOFF
STRT 17,@RQITR
JRST LSPRT1 ;WILL PION WITHIN ERINIT
CKI1:
Q% POP FXP,D ;RETURN TO SERVICE THE DELAYED INTERRUPT
SKIPE INHIBIT ;BUT NO SERVICE WHEN INHIBIT = -1
Q% POPJ P,
Q$ JRST POPXDJ
PUSHJ P,UINTPU
SETZM INTFLG
PUSH P,A
PUSH P,A
HLLOS INHIBIT
SKIPG A,INTAR
LERR EMS13 ;LOST USER INTERRUPT
CKI1A:
Q% MOVS A,INTAR(A)
Q% MOVSM A,(P) ;FOR GC PROTECTION
Q$ MOVS D,INTAR(A)
Q$ MOVSM D,(P)
SOS INTAR ;CYCLE THROUGH THE DELAYED INTERRUPTS
PUSHJ P,UINT0
SKIPLE A,INTAR
JRST CKI1A
SUB P,R70+1
POP P,A
SETZM INTFLG
SETZM INHIBIT
Q% JRST UINTEX
Q$ PUSHJ P,UINTEX
Q$ JRST POPXDJ
IFN QIO,[
CKI2I: SETZ ;EVENTUALLY FLUSH THIS
SIXBIT \RESET\
400000,,TTYIF2+F.CHAN
] ;END OF IFN QIO
IFE QIO,[
SUBTTL OLD I/O CONTROL CHARACTER ROUTINES
;CNTROL: 0
CNTRL1: CAIG A,36 ;NO INTERRUPT CHAR USABLE WITH ASCII > 036
XCT CNTBL(A)
JRST 2,@CNTROL
HRLI A,TRUTH ;SKIPS => WANTS T IN VALUE CELL
HLRZM A,@CNTBL(A)
JRST 2,@CNTROL
;;; ********** TABLE OF CONTROL CHAR ACTIONS **********
CNTBL: JRST CN.AT ;↑@
JRST CN.A ;↑A
10% SKIPA LPTON ;↑B
10$ JFCL ;↑B
SETZM GCGAGV ;↑C
SKIPA GCGAGV ;↑D
IFE D10, JRST CN.E ;↑E
IFN D10, JFCL
IFN MOBIOF, JRST CN.F ;↑F
IFE MOBIOF, JFCL
JRST CN.G ;↑G
JRST CN.H ;↑H
JFCL ;UNUSED CONTROL CHARACTERS, ETC.
REPEAT 4, JFCL ;↑J-↑M
IFN MOBIOF,[
SKIPA DISPON ;↑N
JRST CN.O ;↑O
] ;END OF IFN MOBIOF
IFE MOBIOF, REPEAT 2, JFCL
JFCL ;↑P
SKIPA TAPRED ;↑Q
SKIPA TAPWRT ;↑R
SETZM TAPRED ;↑S
SETZM TAPWRT ;↑T
SETOM PAUSFL ;↑U
SETZM TTYOFF ;↑V
JRST CN.W
JRST CN.X ;↑X
IFN MOBIOF, JRST CN.Y ;↑Y
IFE MOBIOF, JFCL
JRST CN.Z ;↑Z
JFCL ;ALT-MODE NOT MADE INTERRUPT CHAR
JRST CN.34 ;↑\
JRST CN.34 ;[ ;↑]
JRST CN.34 ;↑↑
IFN .-CNTBL-37, WARN [CNTBL LOSSAGE]
;;; IFE QIO,
IFN ITS,[
CN.E: .CLOSE LPTC,
SETZM LPTON
SETZM LPTOPD
JRST 2,@CNTROL
] ;END OF IFN ITS
IFN MOBIOF,[
CN.O: JSR CLZDIS
JRST 2,@CNTROL
] ;END OF IFN MOBIOF
CN.W: HRLI A,TRUTH
HLRZM A,TTYOFF
10% .RESET TYOC, ;RESET TTY OUTPUT CHANNEL
10$ CLRBFO
10X WARN [TTY OUTPUT CLEAR IN TENEX]
JRST 2,@CNTROL
CTRLG: PIOF ;↑G - SUBR 0
MOVE A,[-3,,-3]
JRST CN.G0
CN.X: SKIPA A,[-6,,-2] ;ERRSETABLE (↑X) QUIT
CN.G: MOVE A,[-7,,-3] ;IMMEDIATE (↑G) QUIT
CN.G0: SKIPE UNREAL
JRST CN.G1
SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP
HRREM A,INTFLG
HRR A,CNTROL ;IF CALL CAME FROM IOC, THEN DONT
TRC A,IOC2 ;WANT TO DO A RESET ON THE TYI CHANNEL
TRNE A,-1
CN.G2: HLREM A,INTFLG
JSR INTWAIT
PUSHJ P,CHECKI
JRST 2,@CNTROL
CN.G1: SETZM UNREAR
MOVEM R,QITR
HRRZ R,CNTROL
CAME A,[-3,,-3]
CAIN R,IOC2
JRST CN.G3
MOVE R,UNRC.G
CAME R,XC-3
HRREM A,UNRC.G
MOVE R,QITR
JRST 2,@CNTROL
CN.G3: MOVE R,QITR
JRST CN.G2
;;; IFE QIO
CN.A: HRLI A,TRUTH
HLRZM A,SIGNAL
TLZA A,-1 ;WHEN ↑A HAPPENS, AC A HAS 1 IN IT, AND ↑A INT NO. IS 2
CN.34: SUBI A,34-14.+1 ;CNTRL KEYS 34-36 ARE INT NOS. 14. TO 16.
AOJA A,UINT1
Q% CN.H: ;CONTROL-H BREAK
Q$ CN.B: ;CONTROL-B BREAK
MOVEI A,1 ;CURRENTLY, ALL CONTROL-KEY INTERRUPTS HAVE NIL AS ARG
UINT1:
CN.AT: SKIPN @UINTTB(A) ;FOR ↑@, A MUST HAVE HAD ZERO IN IT
JRST 2,@CNTROL
SKIPE UNREAL
JRST UINT1Q
Q% SETOM PAUSFL
UINT1R: JSR INTWAIT
JRST UINT1A ;NO SKIP MEANS RUNNING INTERRUPT NOW IS OK
INTW3: JRST 2,@CNTROL ;OTHERWISE, A USER PI HAS BEEN STACKED UP
;[UNLESS THERE IS A QUIT SIGNAL PENDING]
UINT1A: PUSH P,CNTROL
10% PUSH P,INT ;INT CONTAINS WHAT WAS IN A UPON ENTRY
10% PUSH P,CPOP1J ;TO INTERRUPT - THUS IS NOW GC PROTECTED
10$ PUSHJ P,UPCHK
10X WARN [TENEX USER INTERRUPT]
JRST UINT
UINT1Q: MOVEM R,QITR
MOVEI R,(A)
CAIN R,3 ;ALARMCLOCK
JRST UINT1S
Q% HRRZ R,CNTROL
Q% CAIN R,IOC2
Q% JRST UINT1S
MOVEM D,QITD
AOS R,UNREAR
CAIG R,LUNREAR
JRST UINT1U
SOS UNREAR
LERR EMS12 ;TOO MANY INTERRUPTIONS
UINT1T: MOVE D,UNREAR(R)
MOVEM D,UNREAR+1(R)
UINT1U: SOJG R,UINT1T
MOVEM A,UNREAR+1
MOVE D,QITD
MOVE R,QITR
JRST 2,@CNTROL
UINT1S: MOVE R,QITR
JRST UINT1R
] ;END OF IFE QIO
SUBTTL UUOH HANDLER (INCLUDING STRT)
;UUOH: 0 ;UUO HANDLER
UUOH0: MOVEM T,UUTSV
LDB T,[331100,,40]
CAIL T,CALL←-33
JRST UUOH0B ;PROBABLY A LISP "CALL" UUO
UUOH2: CAILE T,UUOMAX
SETZ T,
JRST @UUOH2A(T)
UUOH2A: ERRBAD ;0 IS ILGL, ILGL, ILGL
ERROR1 ;LERR ;UNCORRECTABLE LISP ERROR
UUOACL ;ACALL ;KLUDGE FOR NCALLING ARRAYS
UUOAJC ;AJCALL ;JRST VERSION OF ACALL
ERROR1 ;LER3 ;LERR, BUT ALSO PRINT ACCUMULATOR A
ERROR5 ;ERINT ;CORRECTABLE ERROR WITH SIXBIT MSG
POF1 ;PP Z$X ;PRINT OUT Z FROM DDT
STRTOUT ;STRT ;SIXBIT STRING TYPE OUT
ERROR5 ;SERINT ;CORRECTABLE ERROR WITH S-EXP MSG
TOF1 ;TP Z$X ;TYPEP PRINTOUT OF Z FROM DDT
ERRIOJ ;IOJRST ;HAIRY FROB TO GET I/O ERROR MSGS
Q% ERRIOJ==:ERRBAD ;IOJRST IS FOR NEWIO ONLY
IFN .-UUOH2A-1-UUOMAX, WARN [UUOH2A OUT OF PHASE]
UUOACL: PUSH P,UUOH
BAKPRO
UUOAJC: MOVE T,@40 .SEE ASAR
TLNE T,AS<FX+FL>
AOJA T,.+2 ;FOR NUMBER ARRAYS, ENTER AT HEADER+1
PUSH P,[UUONVL] ;FOR OTHER ARRAYS, USE NUMVAL CHECK ROUTINE
XCTPRO
EXCH T,UUTSV
SPECPRO INTACT
JRST @UUTSV
NOPRO
;;; DISPATCH ON "CALL" TYPE UUO, TRAPPING TO INTERPRETER IF NECESSARY
UUOH0B: CAILE T,NJCALF←-33
JRST UUOH2
MOVEM TT,UUTTSV
MOVEM R,UURSV
LDB TT,[270400,,40]
CAIG TT,15 ;LISP "CALL" TYPE UUOS
TDZA R,R
MOVEI R,-15(TT)
HRRZ T,40
UUOH0A: MOVEM T,UUOFN
TLZ T,-1
MOVEI TT,(T)
LSH TT,-SEGLOG
SKIPGE TT,ST(TT)
JRST @UUNAF(R)
TLNN TT,SY
JRST UUOH0C
TLZ R,700000 ;400000 => AUTOLOAD, 200000 => MACRO, 100000 => ALREADY DID AUTOLOAD
UUOH1: HRRZ T,(T)
JUMPE T,UUOH1A
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY
CAILE TT,QAUTOLOAD
JRST UUOH1
2DIF JRST @(TT),UUOTRT,QARRAY
UUOH0C: TLNN TT,SA
JRST UUOH3A
HRRZ TT,ASAR(T) ;HANDLE CASE OF A SAR EFFICIENTLY
CAIN TT,ADEAD
JRST UUOH3A
MOVSI T,(T)
HRRI T,T
JRST @UUAT(R)
UUOH1A: JUMPL R,UUALT1
TLNE R,200000
JRST UUOMER
PUSH P,A
PUSH P,B
SKIPGE A,UUOFN
JRST UUOUER
HLRZ T,(A)
HRRO T,@(T)
UUOH3B: POP P,B
POP P,A
CAIE T,QUNBOUND
JRST UUOH0A
JRST UUOH3A
;;UUO TRANSFER TABLE, ONCE FUNCTION TYPE IS KNOWN
UUOTRT:
IRPS LL,X,[A+S+FS+L+E+FE+MC-AL-]
IFSE X,+, @UU!LL!T(R)
IFSE X,-, UU!LL!T
TERMIN
;;; MOBY DISPATCH TABLE FOR DECODING UUO CALL TYPES!
;;; R=0 => COMPILED ROUTINE CALLING A SUBR TYPE
;;; R=1 => COMPILED ROUTINE CALLING A LSUBR TYPE
;;; R=2 => COMPILED ROUTINE CALLING A FSUBR TYPE
UUAT: UUOARR ;CALLING SUBR - IT'S AN ARRAY **WIN**
UUOS1A ;CALLING LSUBR - IT'S AN ARRAY
UUOS2A ;CALLING FSUBR - IT'S AN ARRAY
UUST: UUOS0 ;CALLING SUBR - IT'S A SUBR **WIN**
UUOS1 ;CALLING LSUBR - IT'S A SUBR
UUOS2 ;CALLING FSUBR - IT'S A SUBR
UUFST: UUOS10 ;CALLING SUBR - IT'S AN FSUBR
UUOS11 ;CALLING LSUBR - IT'S AN FSUBR
UUOSBR ;CALLING FSUBR - IT'S AN FSUBR **WIN**
UULT: UUOS7 ;CALLING SUBR - IT'S AN LSUBR
UUOLSB ;CALLING LSUBR - IT'S AN LSUBR **WIN**
UUOS9 ;CALLING FSUBR - IT'S AN LSUBR
UUET: UUOEXP ;CALLING SUBR - IT'S AN EXPR
UUOS5 ;CALLING LSUBR - IT'S AN EXPR
UUOS6 ;CALLING FSUBR - IT'S AN EXPR
UUFET: UUOS3 ;CALLING SUBR - IT'S A FEXPR
UUOS4 ;CALLING LSUBR - IT'S A FEXPR
UUOEX2 ;CALLING FSUBR - IT'S A FEXPR
UUNAF: UUOS ;CALLING SUBR - IT'S A NONATOMICFUN
UUL2N ;CALLING LSUBR - IT'S A NONATOMICFUN
UUF2N ;CALLING FSUBR - IT'S A NONATOMICFUN
UUALT: HRRZM T,UUALT9 ;FOUND AN AUTOLOAD PROPERTY
TLOA R,400000
UUMCT: TLO R,200000 ;MACROS ARE IGNORED, SORT OF
JRST UUOH1
UUALT1: TLOE R,100000 ;CALLING ANYTHING - IT'S AN AUTOLOAD
JRST UUOH3C ;LOSE IF JUST DID AN AUTOLOAD ALREADY
PUSH P,A
HLRZ A,@UUALT9 ;OTHERWISE AUTOLOAD THE FUNCTION
MOVE T,UUOFN
PUSHJ P,AUTOLOAD ;BETTER SAVE R, BY GEORGE!
POP P,A
MOVE T,UUOFN
JRST UUOH1 ;NOW TRY IT AGAIN
;;; MAY CALL UUOBNC AND UUOBAK ONLY WHEN *RSET IS KNOWN
;;; TO BE NON-NIL - AVOIDS CERTAIN TIMING ERRORS.
UUOBNC: POP P,UUOBKG ;UUOBKG WITH NO CPOPJ
HRROS UUOBKG ;FOR UUO GUYS THAT CALL IAPPLY,
JRST UUOBK0 ; WHICH ITSELF SETS UP A CPOPJ
UUOBAK: POP P,UUOBKG ;WATCH THIS CROCK!
JRST UUOBK7
;;;UUOBKG: 0
UUBKG1: SKIPN V.RSET ;CHECK TO SEE WHETHER IN *RSET MODE
JRST @UUOBKG ;SAVES ALL ACS; T HAS -<# OF ARGS>
UUOBK7: HRRZS UUOBKG
UUOBK0: SKIPE NIL
PUSHJ P,NILBAD
PUSH FXP,TT ;PDLS MUST BE AS FRETURN WOULD WANT
PUSH FXP,R ; TO RESTORE THEM TO
JUMPGE T,UUOBK1 ;IF T>0, THEN ASSUME 0, AND THE
JSP TT,ARGP0 ; ARGS WILL BE FILLED IN LATER
MOVNI TT,(T)
SKIPGE A
SETZ TT,
HRLM TT,(P)
JRST UUOBK8
UUOBK1: PUSH P,R70
UUOBK8: MOVEI TT,-2(FXP)
HRLI TT,(FLP)
PUSH P,TT
HRRZ TT,40
HRLI TT,(SP)
PUSH P,TT
JUMPLE T,UUOBK5
PUSH P,R70
JRST UUOBK6
UUOBK5: PUSH P,[$APPLYFRAME]
UUOBK6: MOVS R,40
HRRI R,CPOPJ
SKIPL UUOBKG ;MAYBE DON'T WANT THE CPOPJ
PUSH P,R
HRRZS UUOBKG
POP FXP,R
POP FXP,TT
JRST @UUOBKG
UUOSBR: HLRZ T,(T) ;*** FSUBR CALLED LIKE FSUBR
MOVEM P,UUPSV
MOVNI R,1
TLOA A,400000
UUOSB2: MOVEI R,1 ;R>0 SAYS DON'T DO FRAME HACKERY
UUOSB3: MOVE TT,40 ;OTHERWISE R HAS -<# OF ARGS>
UUOSB5: TLO T,(PUSHJ P,)
TLNE TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
TLCA T,(JRST#<PUSHJ P,>)
PUSH P,UUOH
UUOSB6: JUMPG R,UUOSB7
EXCH T,R
JSR UUOBKG
EXCH T,R
UUOSB7: TLZ A,-1
TLNE TT,(20←33) ;THE NUMERIC CALL BIT. SEE DEFINITION OF NCALL
AOS T ;FOR NCALL, ENTER AT ENTRY+1
SKIPN VNOUUO
TLNE TT,(2←33) ;THE NO-CLOBBER BIT. SEE DEFINITION OF CALLF
JRST UUOXT0
SOS TT,UUOH
UUOSB4: LDB R,[331100,,(TT)]
CAIN R,XCT←-33
JRST UUOXCT ;MAKE XCT OF UUO WORK
MOVEM T,(TT)
UUOXT0: TLNN T,(34←33) ;CAUSE EXIT TO INDIRECT THRU ACALL
TLO T,(@)
UUOXIT: EXCH T,UUTSV
UUOXT1: MOVE TT,UUTTSV
MOVE R,UURSV
JRST @UUTSV
UUOXCT: LDB R,[220400,,(TT)] ;GET INDEX FIELD OF XCT
JUMPE R,.+2
HRRZ R,@UUOACS-1(R) ;IF NON-ZERO, GET CONTENTS OF THAT AC
ADD R,(TT) ;ADD IN ADDRESS FIELD
HLL R,(TT)
MOVEI TT,(R)
TLNE R,(@)
JRST UUOXCT ;MAKE INDIRECTION WIN
JRST UUOSB4 ;MAKE XCT OF XCT ... OF XCT OF UUO WIN
;;; TABLE OF WHERE TO FIND THE ACS AS THEY WERE ON UUO ENTRY
UUOACS:
IRPS X,,[A B C AR1 AR2A UUTSV UUTTSV D UURSV F FREEAC UUPSV FLP FXP SP]
X
TERMIN
UUOARR: HLRZ R,(T) ;*** ARRAY CALLED LIKE SUBR
MOVSI TT,(@)
JRST UUOS03
UUOS0: SETZ TT, ;*** SUBR CALLED LIKE SUBR
HRRZ R,UUOFN
UUOS03: MOVEM P,UUPSV ;THIS IS TO HELP UUOXCT
HLR TT,(T)
PUSH P,TT
LDB T,[270400,,40]
MOVNS T
PUSH FXP,T
PUSHJ P,ARGCHK ;SKIPS IF OK
JRST UUOS0E
POP FXP,R ;R NOW HAS -<# OF ARGS>
POP P,T
TLNN T,(@) ;FURTHER WORK NEEDED FOR CALLING AN ARRAY
JRST UUOSB3
MOVSI TT,TTS<CN>
HLL A,40 ;UUOSB7 WILL CLEAR LEFT HALF OF A
TLNN A,2000 ;DO NOT SET THE COMPILED-CODE-
IORM TT,TTSAR(T) ; NEEDS-ME BIT FOR A CALLF!
MOVE TT,40
TLZN TT,(20←33)
JRST UUOSB3
TLNN TT,(2←33)
JRST UUOAR2 ;NCALL'ING AN ARRAY MEANS CLOBBER,
PUSH P,[UUONVL] ; IF ANY, SHOULD BE TO ACALL
JRST UUOSB5
UUOAR2: TLNN TT,1000
TLOA T,(ACALL) ;NCALL, BUT NOT NCALLF => ACALL
TLOA T,(AJCALL) ;NJCALL, BUT NOT NJCALF => AJCALL
PUSH P,UUOH
TLZ TT,777000
TLZ T,(@)
JRST UUOSB6
UUONVL: SKOTT A,FX+FL
JRST UUONVE
FIX7: MOVE TT,(A) ;OF COURSE, THE ROUTINE HAD BETTER COME UP
POPJ P, ;WITH SOME LISP NUMBER AS VALUE
UUOS1E: PUSH FXP,D
MOVEI D,1
JRST UUOE3
UUOS2E: MOVEM D,(FXP) ;TAKE THE SPOT ALREADY PUSHED ON FXP
MOVEI D,3
UUOE3: PUSHJ P,SAVX3 ;ARGS WERE ALREADY ON PDL, HENCE MUST BE POPPED OFF
MOVEM B,QF1SB ;SO WE MIGHT AS WELL LIST THEM UP WHILE WE'RE AT IT
MOVE TT,T
JSP R,LIST1
MOVE T,TT
MOVE B,QF1SB
JRST UUOE2
UUOS0E: SUB P,R70+1
UUOS0F: PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,0
UUOE2: TLNE D,2 ;D 1.2 => EXIT ADDRESS ALREADY BEEN HACKED
JRST .+4
MOVE R,40
TLNN R,1000
PUSH P,UUOH
PUSHJ FXP,SAV5M1
PUSH P,[UUOSE1]
MOVE TT,40
HRLS TT
PUSH P,TT ;NAME OF FUNCTION IN LH
TRNN D,1 ;1.1 => LISTING HAS ALREADY BEEN DONE
JSP TT,ARGP0 ;ARGS TO FUNCTION NOW ON PDL
MOVEM D,-1(FXP)
PUSHJ P,RSTX3 ;RECUPERATE - IF POSSIBLE, DO NEW EVALUATION
JRST WNAERR ;OR ELSE CRAP OUT ON WRONG NUMBER ARGS
UUOSE1: PUSHJ FXP,RST5M1
POP FXP,D
POPJ P,
UUOS1: HRRZ TT,(T) ;*** SUBR CALLED LIKE LSUBR
HLRZ T,(T)
EXCH T,UUTSV
JSP R,PDLARG
HRRZ R,UUOFN
PUSHJ P,ARGCK0 ;FORCE CHECKING OF NUMBER OF ARGS
JRST UUOS0F
MOVE TT,40
TLNE TT,(20←33) ;THE NCALL BIT
AOS UUTSV
TLNN TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
PUSH P,UUOH
JSR UUOBKG
JRST UUOXT1
UUOX4B: SKIPN UUOH ;=0 MEANS ENTRY FROM MAP SERIES
JRST (R)
PUSHJ FXP,SAV5M1
PUSH P,CR5M1PJ
JRST (R)
UUOLSB: MOVEM P,UUPSV ;*** LSUBR CALLED LIKE LSUBR
MOVEI A,NIL
HLRZ T,(T)
SKIPN V.RSET
JRST UUOSB2
PUSH FXP,T ;SAVE T (ADDRESS OF LSUBR)
MOVE T,UUTSV
PUSH FXP,T ;SAVE -<# OF ARGS> FOR UUOFUL
HRRZ R,UUOFN ;FOR ARGCK0
PUSHJ P,ARGCK0
JRST UUOS1E
MOVE R,T ;WATCH THIS SHUFFLING OF R, T, AND UUTSV!
JSP T,NPUSH-6 ;SIX SLOTS FOR "APPLY FRAME", ETC.
MOVE T,UUTSV
MOVEM R,UUTSV
MOVEI T,(P)
UUOLB3: AOJG R,UUOLB4 ;SO SLIDE STUFF SIX SLOTS UP THE PDL
MOVE TT,-6(T) ;AT END, T POINTS TO LAST OF THE FIVE
MOVEM TT,(T) ; FRAME SLOTS FOR UUOFUL
SOJA T,UUOLB3
UUOLB4: MOVE TT,40 ;FIGURE OUT IF CALL OR CALLF TYPE
MOVEI R,CPOPJ ; (MAY BE CALL TYPE IF 0 ARGS)
TLO R,(PUSHJ P,) ;FIGURE IT OUT
TLNE TT,1000 ;IT MAY LOOK LIKE WE'RE CONSTRUCTING A PUSHJ
TLCA R,(JRST#<PUSHJ P,>) ; TO THE WRONG PLACE, BUT READ THIS CAREFULLY!
HRR R,UUOH ;RETURN ADDRESS MUST GO UNDER
HRRZM R,-5(T) ; THE FRAME, NOT OVER!!!
HLLM R,-1(FXP) ;SAVE INSTRUCTION TO CLOBBER WITH
MOVEI TT,(T)
PUSHJ P,UUOFUL ;SO STICK AN APPLY FRAME UNDER ARGS, IF ANY
;REMEMBER, UUOFUL EXPECTS TWO FROBS
; ON FXP, AND POPS ONE OF THEM
POP FXP,T ;RESTORE T (ADDRESS OF LSUBR)
MOVE TT,40
JRST UUOSB7
UUOFUL: MOVS R,40 ;PUT FRAME UNDER LSUBR CALL
HRRI R,CPOPJ ;TT POINTS TO LAST OF 5 PDL SLOTS
MOVEM R,(TT) ;USES T,TT,R
MOVEI R,-2(FXP) ;FXP HAS -<# OF ARGS> AND ONE
HRRM R,-3(TT) ; OTHER SLOT AS WELL
HRLM FLP,-3(TT)
HRLM SP,-2(TT)
HRRZ R,40
HRRM R,-2(TT)
POP FXP,T
MOVEI R,(T)
HRLI R,-1(T)
ADDI R,(P)
SKIPN T
SETZ R,
MOVEM R,-4(TT)
MOVE R,[$APPLYFRAME]
MOVEM R,-1(TT)
POPJ P,
UUOS9: SKIPA TT,CILIST ;*** LSUBR CALLED LIKE FSUBR
UUOS7: MOVEI TT,ARGPDL ;*** LSUBR CALLED LIKE SUBR
MOVE R,40
TLNN R,1000
PUSH P,UUOH
HLRZ T,(T)
TLNE R,(20←33) ;THE NCALL BIT
ADDI T,1
PUSH FXP,T
PUSH FXP,XC-1
SKIPN V.RSET
JRST UUOS7A
MOVEI T,1
PUSHJ P,UUOBAK
REPEAT 2, SOS -3(P) ;ALLOW FOR TWO FROBS ON FXP
HRRZM P,(FXP)
UUOS7A: JSP TT,(TT) ;ARGPDL OR ILIST
POP FXP,R
JUMPL R,UUOS7K
SKIPN TT,T
JRST UUOS7H
HRLI TT,-1(TT)
ADDI TT,1(P)
UUOS7H: MOVEM TT,-4(R)
MOVE TT,[$APPLYFRAME]
MOVEM TT,-1(R) ;APPLYFRAME DONE
UUOS7K: MOVEM T,UUTSV
HRRZ R,UUOFN
PUSHJ P,ARGLCK
JRST UUOS2E
POP FXP,T
MOVEI A,0
JRST UUOXIT
UUOS2A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE FSUBR
MOVEM TT,LISAR
MOVEI R,(TT)
MOVEI TT,IAPAR1
JRST UUOS2Q
UUOS2: HLRZ TT,(T) ;*** SUBR CALLED LIKE FSUBR
HRRZ R,UUOFN
UUOS2Q: MOVE T,40
TLNN T,1000
PUSH P,UUOH
TLNE T,(NCALL)
PUSH P,[UUONVL]
CAIN T,IAPAR1
PUSH P,LISAR
PUSH FXP,TT ;SUBR ADDR
CILIST: JSP TT,ILIST ;ILIST FORTUNATELY SAVES R
PUSHJ P,ARGCHK
JRST UUOS2E
JSP R,PDLARG
POP FXP,TT ;PRESERVE T FOR UUOBKG
CAIN TT,IAPAR1
POP P,LISAR
JSR UUOBKG
MOVEI T,(TT) ;BEWARE! LOOSE SUBR POINTER
JRST UUOXIT
UUOS1A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE LSUBR
MOVEM TT,LISAR
MOVEI T,IAPAR1 ;HAIR SO INTERRUPTS WON'T SCREW US
EXCH T,UUTSV
JSP R,PDLARG ;SAVES TT
JSR UUOBKG ;ALSO SAVES TT, AND WANTS NOTHING ON PDLS
LDB R,[TTSDIM,,TTSAR(TT)]
MOVE TT,40
TLNN TT,1000
PUSH P,UUOH
TLNE TT,(NCALL)
PUSH P,[UUONVL]
MOVNI R,(R)
CAMN R,T
JRST UUOXT1
PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,2
JRST UUOE2
;;; PUTCODE [EXPR ← FSUBR]40
UUOS4: POP P,A ;*** FEXPR CALLED LIKE LSUBR
MOVN TT,UUTSV
JRST UUOS4A
UUF2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE FSUBR
UUOS6: HLRZ TT,(T) ;*** EXPR CALLED LIKE FSUBR
MOVE R,40
TLZN TT,-1 ;UUF2N LEAVES LH OF T ↑= 0
HRL TT,R ;OTHERWISE GET SUBR EXPR NAME IN LH
TLNN R,1000
PUSH P,UUOH
TLNE R,(20←33) ;THE NCALL BIT
PUSH P,[UUONVL]
JSP R,UUOX4B
SKIPN V.RSET
JRST UUOS6Q
PUSH P,FXP ;IF IN *RSET MODE, MAKE
HRLM FLP,(P) ; UP AN EVAL FRAME (SEE EVAL
MOVEI C,(A) ; FOR FORMAT THEREOF)
HRRZ B,40
PUSHJ P,XCONS ;MUST CONS UP FAKE ARG TO EVAL
PUSH P,A
HRLM SP,(P)
PUSH P,[$EVALFRAME]
MOVEI A,(C)
UUOS6Q: PUSH P,TT ;PUSH OF FUNCTION
MOVEI TT,IAPPLY
JRST ILIST
UUOS11: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE LSUBR
MOVE T,UUTSV
JRST UUS10A
;;; ENDCODE [EXPR ← FSUBR]
UUOS3: LDB TT,[270400,,40] ;*** FEXPR CALLED LIKE SUBR
UUOS4A: SOJN TT,UUOFER
UUOEX2: MOVEI TT,1 ;*** FEXPR CALLED LIKE FSUBR
DPB TT,[270400,,40]
TLOA A,400000
UUOS: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE SUBR
UUOEXP: HLRZ TT,(T) ;*** EXPR CALLED LIKE SUBR
LDB T,[270400,,40]
UUOEX4: MOVE R,40 ;ALL OF T,TT,R WILL BE LOST!
TLZN TT,-1 ;INSERT EXPR NAME IF WAS EXPR
HRL TT,R
TLNN R,1000
PUSH P,UUOH
MOVN T,T
SKIPE V.RSET
PUSHJ P,UUOBNC
TLNE R,(NCALL)
PUSH P,[UUONVL]
JSP R,UUOX4B
PUSH P,TT ;PUSH FUNCTION
JUMPE T,IAPPLY
MOVEM T,UUTSV
HRLZ R,UUTSV
MOVE A,1(R)
JSP T,PDLNMK
PUSH P,A ;PUSH ARGUMENT
AOBJN R,.-3
MOVE T,UUTSV
JRST IAPPLY ;APPLY FUN TO ARGS
UUOS10: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE SUBR
JSP TT,ARGPDL
UUS10A: AOJN T,UUOFER
POP P,A
MOVSI T,2000
IORM T,40
MOVE T,UUOFN
JRST UUOSBR
UUL2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE LSUBR
UUOS5: HLRZ TT,(T) ;*** EXPR CALLED LIKE LSUBR
MOVE T,UUTSV
CAMGE T,XC-NACS
JRST UUOS5A
JSP R,PDLARG
MOVNS T
JRST UUOEX4
UUOS5A: PUSH FXP,T ;DAMN CASE WHERE WE MUST
PUSH FXP,V.RSET ; SLIDE STUFF UP THE PDL,
MOVEI R,(P) ; DOING PDLNMK'S AS WE GO
JSP T,NPUSH-3-NACS+1 ;ROOM FOR ALL ACS BUT A, PLUS 3
SKIPE (FXP)
JSP T,NPUSH-5 ;EXTRA SLOTS FOR *RSET
MOVEI D,(P)
MOVE F,-1(FXP)
UUOS5B: MOVE A,(R) ;SO DO ALL THE PDLNMK'S
JSP T,PDLNMK
MOVEM A,(D)
SUBI R,1
SUBI D,1
AOJL F,UUOS5B
HRL TT,40 ;TT HAS BEEN SAVED - HAS FN
MOVEM TT,(D) ;SAVE FUNCTION BELOW ARGS FOR IAPPLY
SKIPE (FXP) ;D SHOULD POINT TO WHERE ACS ARE SAVED
SUBI D,5 ;FOR *RSET, MUST SAVE THE ACS UNDER THE FRAME!
REPEAT NACS-1, MOVEM B+.RPCNT,.RPCNT-NACS(D) ;SAVE ALL MARKED ACS BUT A
MOVEI TT,R5M1PJ ;PROVIDE FOR RESTORING THEM
MOVEM TT,-1(D) ;ACS WERE SAVED UNDER, NOT OVER, THE
MOVE TT,40 ; FRAME IN CASE OF AN FRETURN
MOVE F,UUOH ;MAYBE NEED RETURN ADDRESS UNDER
TLNE TT,1000 ; THE ARGS (IF NOT, USE A CPOPJ)
MOVEI F,CPOPJ
MOVEM F,-NACS-1(D)
POP FXP,F
JUMPE F,UUOS5C ;MAYBE MORE *RSET HAIR?
PUSH FXP,(FXP) ;DUPLICATE NUMBER OF ARGS ON FXP
MOVEI TT,4(D) ;TT POINTS TO THE FIVE *RSET SLOTS
MOVEM TT,-1(FXP) ;PLOP POINTER INTO PDL SLOT
PUSHJ P,UUOFUL ;SET UP APPLYFRAME (POPS FXP)
POP FXP,TT
HRRZS (TT) ;FLUSH CPOPJ - IAPPLY WILL CREATE ONE
JRST IAPPLY
UUOS5C: POP FXP,T ;NOW FOR THE IAPPLY
JRST IAPPLY ;UUOFUL WANTS TWO THINGS ON FXP, WILL POP ONE
ARGCHK: CAMGE T,XC-NACS ;CHECK NUMBER OF ARGS SUPPLIED
JRST PAERR ;R HAS ATOM PROPERTY LIST POINTER
ARGLCK: SKIPE V.RSET
JRST ARGCK2
ARGCK1: POP P,TT ;FOR SPEED, DO THIS RATHER THAN
JRST 1(TT) ;AOS (P) POPJ P,
ARGCK2: SKOTT R,SY ;R HAS SYMBOL OR SAR
JRST ARGCK5 ;MUST BE A SAR
ARGCK0: HLRZ R,(R)
HLRZ R,1(R)
JUMPE R,ARGCK1
LDB TT,[111100,,R]
JUMPN TT,ARGCK3
ARGCK4: LDB TT,[001100,,R]
MOVNI TT,-1(TT)
CAMN T,TT
AOS (P)
POPJ P,
ARGCK3: MOVNI TT,-1(TT)
CAMLE T,TT
POPJ P,
LDB TT,[001100,,R]
CAIN TT,777 ;777 IS EFFECTIVELY INFINITY
JRST POPJ1
MOVNI TT,-1(TT)
CAML T,TT
AOS (P)
POPJ P,
ARGCK5: LDB R,[TTSDIM,,TTSAR(R)]
AOJA R,ARGCK4
ARGPDL: LDB T,[270400,,40] ;ARGS => PDL -CNT=> T
MOVNS T
ARGP0: HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
PDLARG: CAMGE T,XC-NACS
PAERR: LERR EMS16 ;MORE THAN 5 ARGS
JRST .+1+NACS(T)
REPEAT NACS,[CONC RSTR,\<A-1+NACS-.RPCNT>,: POP P,A-1+NACS-.RPCNT
]
PDLA2: JRST (R)
MOVEI D,QSUBRCALL ;COME HERE IF SUBRCALL (Q.V.) GOT 0 ARGS
SOJA T,WNALOSE
STRTOUT: MOVE T,UUTSV
PUSH P,UUOH
PUSH P,A
PUSHJ P,SAVX5
PUSH FXP,40
IFN QIO,[
PUSH P,AR1
PUSH P,AR2A
LDB D,[270400,,(FXP)] ;AC=17 MEANS USE MSGFILES.
CAIN D,17
JRST ERP0D
SKIPN AR1,(D) ;NIL MEANS USE DEFAULT ↑R AND ↑W
JRST ERP0C
ERP0E: TLO AR1,200000
ERP0F: MOVEI A,(AR1)
LSH A,-SEGLOG
SKIPL ST(A) ;MAYBE SHOULD ERRR-CHECK BETTER?
TLO AR1,400000 ;NOTE WHETHER LIST OR NOT
ERP0A: JSP T,GTRDTB
.5LOCKI
ERBPLOC==-1 ;LOCATION OF BYTE PTR ON FXPDL
] ;END OF IFN QIO
IFE QIO, ERBPLOC==0
MOVSI D,440600
HLLM D,ERBPLOC(FXP)
ERP1: ILDB TT,ERBPLOC(FXP) ;STRING BYTE POINTER IS STORED ON FXP
CAIN TT,'# ;THE .5LOCKI SAVED INHIBIT ON TOP OF FXP
JRST ERP3
CAIN TT,'!
JRST ERP6
CAIN TT,'↑
JRST ERP4
ERP5: ADDI TT,40
ERP5A: PUSHJ P,STRTYO
JRST ERP1
IFN QIO,[
ERP0D: SKIPN AR1,VMSGFILES
JRST ERP6A
JRST ERP0E
ERP0C: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
JUMPN AR1,ERP0F
SKIPE TTYOFF
JRST ERP6A
JRST ERP0A
] ;END OF IFN QIO
ERP3: ILDB TT,ERBPLOC(FXP) ;QUOTE A CHAR
JRST ERP5
ERP4: ILDB TT,ERBPLOC(FXP) ;CONTROLLIFY A CHAR
ADDI TT,40
TRC TT,100
Q$ CAIE TT,↑M
JRST ERP5A
Q$ PUSHJ P,STRTYO
Q$ MOVEI TT,↑J
Q$ JRST ERP5A
ERP6:
IFN QIO,[
UNLOCKI ;DONE!
ERP6A: POP P,AR2A
POP P,AR1
] ;END OF IFN QIO
SUB FXP,R70+1 ;FLUSH BYTE PTR
POP P,A ;RESTORE A
JRST RSTX5 ;RESTORE NUMACS AND POPJ
ENDFUN==.-1 .SEE SSYSTEM ;NO MORE FUNCTIONS BEYOND HERE
SUBTTL INITIAL STARTUP CODE
LISP:
IFN USELESS*<1-D10>, JSP T,SHAREP
10% Q% SETZM LPTOPD
Q% SETZM UTOOPD ;NORMAL REENTRY POINT
Q% SETZM UTIOPD ;COME HERE FROM LISPGO
IFN MOBIOF,[
SETZM FTVU
SETZM BVDOPD
SETZM NVDOPD
SETZM DISOPD
SETZM DISPON
] ;END OF IFN MOBIOF
SETZM TAPWRT
SETZM TTYOFF
REPEAT NFF, SETZM FFS+.RPCNT ;SET FREELISTS TO NIL
IFN HNKLOG, MOVSI A,(SETZ)
REPEAT HNKLOG,[
SKIPN HNSGLK+.RPCNT ;HACK TO AVOID CREATING
MOVEM A,FFH+.RPCNT ; UNNEEDED HUNK SEGMENTS
] ;END OF REPEAT HNKLOG
SETZM GCTIM
SETZM ALGCF
IFN ITS,[
.SUSET [.SPIRQC,,R70]
.SUSET [.SIFPIR,,R70]
IFE QIO,[
SETZM LPTON
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFE QIO
.SUSET [.ROPTION,,TT]
Q$ TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
Q$ .SUSET [.SOPTION,,TT]
TLNN TT,OPTBRK
JRST LISP17
.BREAK 12,[..RSTP,,TT] ;READ SYMBOL TABLE POINTER
JUMPGE TT,LISP17
.VALUE [ASCIZ /↔..TAMP\
..TPER\≠1Q
..TAMP\P%
:VP /]
LISP17:
] ;END OF IFN ITS
JSP A,ERINIT ;SETS UP PDLS AND I/O SWITCHES
JSP T,TLVRSS
IFN EDFLAG, SETOM EDPRFL
IFN ITS,[
Q% .SUSET [.SMASK,,INTMSK]
Q$ INTON
Q% MOVE TT,IUSN
Q% MOVEM TT,USN
Q% .SUSET [.SSNAM,,USN]
Q% PUSHJ P,TTYOPN
Q$ MOVE TT,IUSN
Q$ MOVEM TT,TTYIF2+F.SNM
Q$ MOVEM TT,TTYOF2+F.SNM
IFN JOBQIO,[
.DTTY
JFCL
] ;END OF IFN JOBQIO
Q$ PUSHJ P,OPNTTY
JFCL
MOVSI T,111111
PUSHJ P,GCNRT
.CALL LISP43
.VALUE
Q% PUSHJ P,SUNAM1
Q$ PUSHJ P,SIXATM
HRLM A,MACHFT ;SET UP (STATUS FEATURES) FOR MACHINE NAME
] ;END OF IFN ITS
;;; FALLS THRU
;;; FALLS THRU
IFN D10,[
MOVEI TT,INT0
MOVEM TT,.JBAPR"
MOVEI TT,630000
APRENB TT,
MOVEI A,IN0+72.
MOVEM A,VLINEL
MOVEM A,OLINEL
] ;END OF IFN D10
MOVE TT,BPSH
CAMGE TT,@VBPEND
PUSHJ P,BPNDST
IFN D10,[
MOVEI T,TTYINT
MOVEM T,.JBREN"
SETOM UPCOK
PUSHJ P,GCNRT
SA$ SETZ T,
SA$ CALLI T,400071
SA% GETPPN T,
SA% JFCL
MOVEM T,USN
MOVE F,[4,,T]
MOVNI T,1
SETZB TT,D
MOVEI R,0
SA% PATH. F,
MOVE D,USN ;FAILED
PUSHJ P,SUNM2
] ;END OF IFN D10
;FALLS THROUGH
;FALLS IN
IFE D10,[
Q% MOVE A,[440600,,USN] ;SAME AS IUSN (SEE ABOVE)
IFN QIO,[
PUSH FXP,IUSN
PUSH FXP,R70
MOVEI A,-1(FXP)
HRLI A,440600
] ;END OF IFN QIO
PUSHJ P,READ6C
Q$ SUB FXP,R70+2
] ;END OF IFE D10
MOVEM A,SUDIR
IFE QIO,[
PUSHJ P,NCONS
MOVEI B,QDSK
PUSHJ P,XCONS
MOVEM A,IUNIT ;INSTALL CURRENT USER IN IUNIT
MOVEI T,<↑C>←13
HRLZM T,UTIB+UTBSIZ
] ;END OF IFE QIO
IFN MOBIOF, PUSHJ P,CLSSIX
MOVEI T,INR70 ;LOCATION OF LAP CONSTANTS
MOVEM T,VTTSR
MOVEI A,Q. ;INITIAL VALUE OF * IS *
MOVEM A,V.
MOVE A,VERRLIST ;SET UP FOR EVAL'ING ERRLIST
MOVEM A,VIQUOTIENT
PION ;ENABLE INTERRUPTING
SKIPGE AFILRD
JRST LSPRET
LIHAC:
Q% AOS UTIOPD ;HAIRY HAC TO READ, THE FIRST TIME
SETOM AFILRD ; AROUND, FROM THE .LISP. (INIT) FILE
MOVEI A,TRUTH
MOVEM A,TAPRED
JRST HACENT
IFN ITS,[
LISP43: SETZ
SIXBIT \SSTATU\
REPEAT 5, 2000,,TT ;IGNORE USELESS GARBAGE
Q% 402000,,UNMTMP ;MACHINE NAME
Q$ 402000,,TT ;MACHINE NAME
IFE QIO,[
TTYOPN: .OPEN TYIC,OTYIC
.VALUE
.OPEN TYOC,OTYOC
.VALUE
.CALL RTTYS
.VALUE
TLO R,%TS<CLE+ACT+MOR>
MOVEM R,STTYSS
.CALL CNSGT1
.VALUE
ANDI TT,777
IOR D,TT
MOVEM D,TTYDISP
MOVEM D,SRNLN1
MOVEI A,IN0(TT) ;A NUMBER FOR TTY TYPE
MOVEM A,VTTY ; (GUARANTEED NLISP INUM)
JSP T,WAKTTY
.CALL RSSBLK ;WANT TO LEAVE IN ACC TT THE WIDTH OF THE SCREEN IN CHARS
.VALUE
SUBI TT,1 ;LINE LENGTH RETURNED BY SYSTEM MAY BE 2 TOO LONG
SUBI D,1
SKIPE SRNLN1
MOVEM D,SRNLN1
CAILE TT,777 ;CONCEIVABLY THE LINEL IS SET HUGE
MOVEI TT,777
MOVEI A,IN0(TT) ;SET UP LINEL (GUARANTEED NLISP INUM)
MOVEM A,VLINEL
MOVEM A,OLINEL
POPJ P,
CNSGT1: SETZ
SIXBIT \CNSGET\
1000,,TYIC
2000,,TT
2000,,TT
2000,,TT
2000,,D
402000,,D
OTYIC: (SIXBIT \TTY\)
SIXBIT \.LISP.\
SIXBIT \INPUT\
OTYOC: (21+SIXBIT \TTY\)
SIXBIT \.LISP.\
SIXBIT \OUTPUT\
RSSBLK: SETZ
SIXBIT \RSSIZE\
1000,,TYIC
2000,,TT+1 ;SCREEN HEIGHT
402000,,TT ;SCREEN WIDTH (LINEL)
RTTYS: SETZ
SIXBIT \TTYGET\
1000,,TYIC
2000,,TT ;TTYST1 (WORD ONE CHARACTER BITS)
2000,,D ;TTYST2 (WORD TWO)
402000,,R ;TTYSTS
WAKTTY: .CALL STTYS
.VALUE
JRST (T)
STTYS: SETZ
SIXBIT \TTYSET\
1000,,TYIC
STTYS1 ;TTYST1
STTYS2 ;TTYST2
400000,,STTYSS ;TTYSTS
] ;END OF IFE QIO
] ;END OF IFN ITS
10$ WAKTTY: JRST (T)
IFN ITS,[
Q% TMPC==DSIC
NOSHARE==JRST (T) ;DEPOSIT INTO SHAREP TO INHIBIT SHAREING
SHAREP: SKIPN SAWSP
JRST (T)
SETZM SAWSP
.CALL PURCHK
.VALUE
JUMPLE TT,(T)
.OPEN TMPC,SYSFIL
JRST (T)
.ACCESS TMPC,[2000+BPURPG]
MOVE TT,[-NPURPG,,BPURPG/PAGSIZ]
.CALL PURPGS ;SHARE PURE CODE
.VALUE
.ACCESS TMPC,[2000+BPURFS-<NXVCSG+NXXZSG>*SEGSIZ]
MOVE TT,[-NPURFS,,BPURFS/PAGSIZ]
.CALL PURPGS ;SHARE PURE DATA AREAS
.VALUE
.CLOSE TMPC,
JRST (T)
PURCHK: SETZ
SIXBIT \CORTYP\ ;GET TYPE FOR CORE BLOCK
1000,,BPURPG/PAGSIZ ;LOWEST PURE BLOCK
402000,,TT ;>0 READ-ONLY, <0 WRITABLE
SYSFIL: SIXBIT \ &SYS\ ;FOR OPENING UP FILE TO SHARE
Q% SIXBIT \PURBIB\
Q$ SIXBIT \PURQIO\
LVRNO
PURPGS: SETZ
SIXBIT \CORBLK\ ;HACK CORE BLOCKS
1000,,200000 ;GET READ-ONLY PAGES
1000,,-1 ;PUT THEM INTO *MY* PAGE MAP
,,TT ;AOBJN POINTER FOR PAGES
401000,,TMPC ;DISK FILE TO SHARE WITH
] ;END OF IFN ITS
SUBTTL INTERNAL PCLSR'ING ROUTINES
SFXTBL: ;TABLE OF LOCATIONS FOR SFX HACK
MACROLOOP NSFC,ZZM,*
SFXTBI: ;TABLE OF INSTRUCTIONS NORMALLY IN THOSE LOCATIONS
MACROLOOP NSFC,ZZN,*
PROTB: ;TABLE OF INTERRUPT PROTECTION INTERVALS
MACROLOOP NPRO,PRO,*
;;; TABLE MUST BE AN EXACT POWER OF TWO IN LENGTH SO WE CAN
;;; USE SUPER-WINNING BINARY SEARCH METHOD.
HAOLNG LOG2NPRO,<.-PROTB-1>
REPEAT <1←LOG2NPRO>-NPRO,[ INTOK,,777777
] ;END OF REPEAT <1←LOG2NPRO>-NPRO
;;; IT IS OBVIOUSLY USELESS TO USE PROTECT MACROS BEYOND THIS POINT.
;;; EXPUNGING NPRO WILL CAUSE AN ERROR IF THE PROTECT MACROS ARE USED
EXPUNGE NPRO
IFE QIO,[
;INTWAIT: 0
INTW0: MOVEM C,QITC ;.SUSET PIHOLD TO BE DONE BEFORE ENTERING
MOVEM D,QITD ; (INTERRUPT ENTRY IN EFFECT IS A PIHOLD)
MOVEM R,QITR
SKIPE WAITFL
JRST INTW4 ;BUSY DOING SFX HACK - GO STACK UP INTERRUPT
HLRZ C,NOQUIT ;IF IN GC, NEEDN'T CHECK SP - IT WILL
JUMPN C,INTW1 ; UNDOUBTEDLY BE IN STRANGE STATE ANYWAY
MOVE C,(SP) ;ALLOWS SPDL TO GET CAUGHT UP,
MOVEI D,(SP) ; OR CONSER TO FINISH HIS EXCH'S,
CAME D,ZSC2 ; BUT SKIPS 1 IF IN GC
CAMN C,SPSV ; (LH OF NOQUIT NONZERO)
JRST INTW1
INTSFX: SETOM WAITFL ;SET FLAG FOR SFX HACKERY
MOVEM A,WAITA ;SAVE A
MOVE A,INT
MOVE D,[JSR SPWR]
MOVSI R,-NSFC
MOVEM D,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO
AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN HERE
MOVE D,QITD ;RESTORE ACS
MOVE C,QITC
MOVE R,QITR
IFN ITS,[
.SUSET [.SDF1,,[<-1>#<IB.PDLOV+IB.MPV+IB.ILOP+IB.PUR>]]
.SUSET [.RDF2,,WAITD2] ;DEFER MOST NON-NASTY INTERRUPTS
.SUSET [.SDF2,,XC-1]
.DISMISS IPCLOK ;ENABLE INTERRUPTS IN CASE OF PDL OVERFLOW, ETC.
] ;END OF IFN ITS
10$ JRST 2,@IPCLOK
10X WARN [INTERRUPT RETURN IN TENEX]
;;; IFE QIO
;SPWR: 0
SPWR0: PIOF
IFN ITS,[
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,WAITD2]
] ;END OF IFN ITS
MOVEM R,QITR
MOVEM C,QITC ;SAVE ACS
MOVEM D,QITD
MOVEM A,INT
MOVE A,WAITA
MOVSI R,-NSFC
MOVE D,SFXTBI(R) ;RESTORE LOCATIONS CLOBBERED BY JSR'S
MOVEM D,@SFXTBL(R)
AOBJN R,.-2
SOS C,SPWR ;BACK UP PC TO CLOBBERED INSTRUCTION
MOVEM C,IPCLOK
SETZM WAITFL ;SURVIVED SFX HACK - EVERYTHING'S HAPPY
JRST INTW2
INTW1: HRRZ C,IPCLOK
JUMPE C,INTOK
MOVEI D,0 ;FAST BINARY SEARCH OF PROTECT TABLE
REPEAT LOG2NPRO,[
MOVE R,PROTB+<1←<LOG2NPRO-.RPCNT-1>>(D)
CAIL C,(R)
ADDI D,1←<LOG2NPRO-.RPCNT-1>
] ;END OF REPEAT LOG2NPRO
HLRZ R,PROTB(D)
JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL
INTXCT: MOVE R,QITR ;RESTORE ACS
MOVE D,QITD
MOVE C,QITC
EXCH A,INT ;NOTE: FLAGS ARE NOT RESTORED
XCT @IPCLOK ;EXECUTE AN INSTRUCTION
JRST .+2
AOS IPCLOK ;HANDLE SKIPS CORRECTLY - SEE UUOACL
AOS IPCLOK
MOVEM C,QITC
MOVEM D,QITD
MOVEM R,QITR
EXCH A,INT
JRST INTW1 ;TRY AGAIN - MAYBE MORE TO XCT
;;; IFE QIO
INTSYP: SOS NPFFY2 ;PROTECT SYMBOL CONSER
INTSYQ: SOS NPFFY2
INTSYX: MOVEI C,SYCONS
JRST INTBK1
INTROT: MOVE C,PROTB(D) ;PROTECT CODE OF THE FORM
SUBI C,1 ; ROT A,-SEGLOG
HRRM C,IPCLOK ; ... MUNCH ...
EXCH A,INT ; ROT A,SEGLOG
ROT A,SEGLOG
EXCH A,INT
JRST INTOK
INTPPC: MOVE C,PROTB(D) ;PROTECT PURE CONSER
SUBI C,1 ;BACK UP TO THE AOSL OR WHATEVER
HRRM C,IPCLOK
SOS @(C) ;RESTORE THE COUNTER
JRST INTOK
INTC2X: HLRM B,INT ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI C,CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTACT: HRRZ C,UUTSV ;UUOACL
JRST INTW1
IFE QIO,[
INTTYI: MOVEI C,TYIN ;PROTECTS THE CASE OF PTYBF FILLED
JRST INTBK1 ; WHEN INTERRUPTED FROM TTYTYI
] ;END OF IFE QIO
INTZAX: SETZM INT ;FOR CONSERS WHICH DON'T WANT TO PROTECT THEIR FREELIST!
INTACX: MOVSS INT ;FOR ACONS (RESTORES A FOR BACKUP)
INTBAK: MOVE C,PROTB(D) ;BACK UP PC TO BEGINNING
INTBK1: HRRM C,IPCLOK ; OF INTERVAL
INTOK:
10$ CAIL C,400000 ;NO ARRAYS IN HIGH SEGMENT!
10$ JRST INTW2
CAML C,@VBPEND
JRST INTSFX
INTW2: HLRZ C,NOQUIT
JUMPE C,INTW5
INTW4: AOS C,INTWAIT ;GC IS IN PROGRESS - CAUSES SKIP UPON EXIT
MOVEI C,(C)
CAIN C,INTW3
SKIPN @UINTTB(A)
JRST INTW5
MOVE D,QITD ;MUST RESTORE D AND R SO UISTAK
MOVE R,QITR ; CAN SAVE THEM AGAIN
JSR UISTAK ;STACK UP, IF PI IS USER-ENABLED
INTW5: MOVE D,QITD ;RESTORE ACS
MOVE R,QITR
MOVE C,QITC
JRST 2,@INTWAIT ;RETURN TO CALLER
] ;END OF IFE QIO
IFN QIO,[
;;; PUSHJ FXP,IWAIT
;;; CALLED FROM WITHIN A NORMAL INTERRUPT HANDLER TO DECIDE
;;; WHETHER IT IS SAFE TO ISSUE A USER INTERRUPT.
;;; ON FAILURE, STACKS UP THE INTERRUPT AND SKIPS.
;;; AS FOR UINT0, D CONTAINS THE INTERRUPT DESCRIPTOR WORD.
;;; INTERRUPTS MUST BE DEFERRED; PDL OVERFLOW MUST BE
;;; ENABLED. THE CONTENTS OF INTPDL POINTS TO THE INTPDL ENTRY
;;; FOR THE CURRENT INTERRUPT, WHICH CONTAINS THE SAVED
;;; CONTENTS OF D AND R. FXP MUST BE IN A USABLE STATE.
IWAIT: HLRZ R,NOQUIT ;IF IN GC, WE ARE IN A BAD STATE
JUMPN R,IWSTAK ; AND SO MUST STACK THE INTERRUPT
MOVEI R,(SP) ;IF THE SPECPDL IS IN SOME
MOVE F,(SP) ; KIND OF STRANGE STATE (E.G.
CAME R,ZSC2 ; INTERRUPTED OUT OF SPECBIND)
CAMN F,SPSV ; THEN MUST DO THE INTSFX HACK
JRST IWLOOK
INTSFX: MOVE F,[PUSHJ FXP,SPWIN]
MOVSI R,-NSFC
MOVEM F,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO
AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN TO SPWIN
HRRZ F,INTPDL ;RESTORE AC'S, AND SAVE
EXCH D,IPSWD2(F) ; INTERRUPT DESCRIPTOR
MOVE R,IPSWD1(F)
PUSH FXP,IPSPC(F) ;GET PC AND FLAGS
MOVE F,IPSF(F)
JRST 2,@(FXP) ;CONTINUE WHATEVER WE WERE DOING
;;; IFN QIO
;;; RETURN FROM SFX HACK. ROUTINE HAS DONE PUSHJ FXP,SPWIN.
SPWIN: HRRZ F,INTPDL
POP FXP,IPSPC(F) ;PUT PC BACK INTO INTPDL FRAME,
SOS IPSPC(F) ; BACKED UP TO THE CLOBBERED INSTRUCTION
SUB FXP,R70+1
MOVEM R,IPSWD1(F) ;SAVE AC'S
EXCH D,IPSWD2(F)
MOVSI R,-NSFC
SPWIN1: MOVE F,SFXTBI(R) ;RESTORE THE LOCATIONS THAT WE
MOVEM F,@SFXTBL(R) ; CLOBBERED WITH PUSHJ FXP,SPWIN
AOBJN R,SPWIN1
JRST IWWIN ;WE HAVE WON
IWLOOK: HRRZ F,INTPDL ;FAST BINARY SEARCH OF PROTECT
HRRZ R,IPSPC(F) ; TABLE ON PC INTERRUPTED FROM
PUSH FXP,D
MOVEI D,0
REPEAT LOG2NPRO,[
MOVE F,PROTB+<1←<LOG2NPRO-.RPCNT-1>>(D)
CAIL R,(F)
ADDI D,1←<LOG2NPRO-.RPCNT-1>
] ;END OF REPEAT LOG2NPRO
MOVS R,PROTB(D)
POP FXP,D
HRRZ F,INTPDL ;A USEFUL VALUE FOR F
JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL
INTXCT: PUSH FXP,IPSPC(F)
EXCH D,IPSWD2(F) ;RESTORE AC'S
MOVE R,IPSWD1(F) ;FLAGS ARE *NOT* RESTORED
MOVE F,IPSF(F) ; ALSO, FXP IS OUT OF WHACK
XCT @(FXP) ;EXECUTE AN INSTRUCTION
JRST .+2
AOS (FXP) ;HANDLE SKIPS CORRECTLY
AOS (FXP) .SEE UUOACL
HRRZ F,INTPDL
MOVEM R,IPSWD1(F)
EXCH D,IPSWD2(F)
POP FXP,IPSPC(F)
JRST IWLOOK ;MAY NEED TO XCT SOME MORE
;;; IFN QIO
INTSYP: SOS NPFFY2 ;PROTECT SYMBOL CONSER
INTSYQ: SOS NPFFY2
INTSYX: MOVEI R,SYCONS
JRST INTBK1
INTROT: HLRZ R,R ;PROTECT CODE OF THE FORM
SUBI R,1 ; ROT A,-SEGLOG
ROT A,SEGLOG ; ... MUNCH ...
JRST INTBK1 ; ROT A,SEGLOG
INTPPC: HLRZ R,R ;PROTECT PURE CONSER
SUBI R,1 ;BACK UP TO THE AOSL OR WHATEVER
HRRM R,IPSPC(F)
SOS @(R) ;RESTORE THE COUNTER
JRST INTOK
INTC2X: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI R,CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTACT: HRRZ R,UUTSV ;UUOACL
JRST IWLOOK
INTTYY: SKIPA R,[INTTYS] ;PROTECTS $DEV4J
INTTYX: MOVEI R,INTTYR ;PROTECTS TYOTYI
HRRZS INHIBIT .SEE .5LKTOPOPJ
JRST INTBK1
INTZAX: TDZA A,A ;FOR CONSERS WHICH DON'T WANT TO PROTECT THEIR FREELIST!
INTACX: MOVSS A ;FOR ACONS (RESTORES A FOR BACKUP)
INTBAK: HLRZ R,R ;BACK UP PC TO BEGINNING
INTBK1: HRRM R,IPSPC(F) ; OF INTERVAL
INTOK: TLZ R,-1
10$ CAIL R,400000 ;NO ARRAYS IN HIGH SEGMENT!
10$ JRST IWWIN
CAML R,@VBPEND
JRST INTSFX
IWWIN: HRRZ F,INTPDL ;WE HAVE WON!
POPJ FXP,
;;; NEED WE PIOF AROUND THIS JSR UISTAK ??
IWSTAK: JSR UISTAK ;WE ARE IN A BAD STATE --
AOS (FXP) ; STACK UP THE INTERRUPT
JRST IWWIN
] ;END OF IFN QIO
PGTOP INT,[INTERRUPT AND UUO HANDLERS]
SUBTTL STRUCT INSERT, BIT TABLES, AND SPACE CALCULATIONS
IFE LOPATCH,[
EXPUNGE PATCH PAT XPATCH
PATCH: PAT: XPATCH: BLOCK PTCSIZ
EPATCH==.-1
] ;END OF IFE LOPATCH
PAGEUP
10$ BSYSSG==HILOC-STDHI ;CROCK - BEWARE RELOCATION!
SPCTOP SYS,,[SYSTEM]
10$ EXPUNGE BSYSSG
NPURPG==<.-BPURPG>/PAGSIZ
10$ $LOSEG
INUM==.
;;@ STRUCT 204 INITIAL LIST STRUCTURE
SUBTTL MACROS FOR CREATING INITIAL LIST STRUCTURE
PFXEST==3000 ;ESTIMATED SPACE NEEDED FOR PURE FIXNUMS
SYMEST==1000 ;ESTIMATED INITIAL NUMBER OF LISP SYMBOLS
LSYALC==20
GSNSYSG==<SYMEST+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF SYM SEGS NEEDED
GSNPFXSG==<PFXEST+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF PFX SEGS NEEDED
IFNDEF NXVCSG, NXVCSG==ITS*2
.NSTGWD ;NO STORAGE WORDS OVER MACRO DEFINITIONS
KNOB==0 ;NUMBER OF OBJECTS FOR OBARRAY
.XCREF KNOB
DEFINE PUTOB A
ADDOB \A-.RL1,\KNOB
TERMIN
DEFINE ADDOB A,N
DEFINE OBT!N
.RL1+A
TERMIN
KNOB==KNOB+1
TERMIN
;;; STANDARD FUNCTION MAKERS
;;; MKAT <PNAME/INTERNAL-NAME>,<PROP-NAME>,<SPACE-FOR-Q-LABEL>,<ARGS-PROP>
;;; MKAT1 <PNAME>,<PROP-NAME>,<SPACE-FOR-Q-LABEL>,<INTERNAL-NAME>,<ARGS-PROP>
DEFINE MKAT A,B,C,D
Q!B %
A,,
RMTAH1 [C]A,PNL-2,[A]D,SUNBOUND,100
TERMIN
DEFINE MKAT1 A,B,C,D,E
Q!B %
D,,
RMTAH1 [C]D,PNL-2,[A]E,SUNBOUND,100
TERMIN
;;; MKAT2 USED TO CREATE AUTOLOAD ATOMS
;;; MKAT2 <ATOM-NAME>,<BRIEF-NAME-FOR-AUTOLOAD-PROP>,<LABEL-FOR-HEADER>
DEFINE MKAT2 A,D,C
QAUTOLOAD %
QFL.!D,,
IFSN [C], MKAT2A [A]C
IFSE [C], MKAT2A [A]A
TERMIN
DEFINE MKAT2A PN,D
RMTAH1 [ ]D,PNL-2,[PN],SUNBOUND,100
TERMIN
;;; MAKES AN ATOM WITH A VALUE CELL, BUT NO OTHER PROPERTIES
;;; MKAV <PNAME>,<LABEL-FOR-VCELL>,<CONTENTS-OF-VCELL>,<LABEL-FOR-HEADER>
DEFINE MKAV A,B,C,D
IFSN [D], RMTAH1 [ ]D,,A,,C.,100
IFSE [D], RMTAH1 ,,,A,,C.,100
C..==.
LOC C.
IFSN [B], B:
.ELSE, V!A:
IFSN [C], C
.ELSE, NIL
C.==.
LOC C..
TERMIN
;;; MAKES A FUNCTION WITH A VALUE CELL
;;; MKFV <PNAME>,<INTERNAL-NAME>,<PROP-NAME>,<INITIAL-VALUE>,<ARGS-PROP>
DEFINE MKFV A,B,C,D,E
Q!C %
B,,
RMTAH1 [ ]B,PNL-2,[A]E,V!B,100
RMTVC V!B,D
TERMIN
;;; STRINGS TOGETHER THE WORDS OF A PNAME INTO A LIST
DEFINE APN,PN
(F.)!REPEAT <<.LENGTH }PN}>+4>/5-1,[%
(F.+.RPCNT+1)]
PNL==.
LOC F.
ASCII }PN}
F.==.
LOC PNL
TERMIN
;;; MAKES A "SYSTEM" ATOM. USUSALLY HAS NO PROPERTIES.
;;; MSA <INTERNAL-NAME>,<PNAME>
DEFINE MSA LN,PN
RMTAH1 [ ]LN,,PN,,SUNBOUND,100
TERMIN
;;; C = <SPACE> MEANS THAT WE SHOULD HAVE A LABEL FOR THE HEADER
;;; D IS THE LABEL, MORE OR LESS, IF C IS A <SPACE>
;;; PL IS FLAG FOR PROPERTY LIST. IF NULL, THEN NIL [= 0] GETS
;;; ASSEMBLED. OTHERWISE, IT MUST BE "PNL-2", SINCE THE PROPERTY
;;; LIST WILL ALWAYS HAVE 2 CELLS JUST PRECEEDING THE PNAME-LIST
;;; PN IS THE PNAME STRING, AR THE ARGS PROPERTY, V THE LABEL OF THE VALUE CELL
DEFINE RMTAH1 C,D,PL,PN,AR,V,UC
PNL==.
LOC S.
PUTOB .
IFSE [C] , Q!D:
B.,,PL
S.==.
LOC B.
UC\777200,,V
NN!AR,,PNL
B.==.
LOC PNL
APN [PN]
TERMIN
;;; REMOTE VALUE CELL MAKER
DEFINE RMTVC A,C
ZZ==.
LOC C.
A:
IFSN [C], C
.ELSE, NIL
C.==.
LOC ZZ
TERMIN
;;; ARGS TO IRP IN GROUPS OF 4 FOR EASY COUNTING
IRP Q,,[0,,1,2
3,4,5,01
12,23,16,36
08,1777,2777,02
13,34,35,45
03,27,37,04
3777]R,,[1,0,2,3
4,5,6,1002
2003,3004,2007,4007
1011,2777,3777,1003
2004,4005,4006,5006
1004,3010,4010,1005
4777]
NN!Q==R
TERMIN ;FOR BIBOP ARGS PROPERTIES
SUBTTL STARTS FOR SAR, VC, IS2, AND SYM [SYMBOL-HEADER] SPACES
;;; STATE OF THE WORLD HERE HAD BETTER BE
;;; 1) LOSEG IF IN D10
;;; 2) BEGINNING ON A SEGMENT BOUNDARY
.XCREF RMTAH1 MKAT MKAT1 MKAT2 MKAV MKFV RMTVC MSA
.XCREF MKAT2A
.YSTGWD ;STORAGE WORDS ARE OKAY NOW
PGBOT ATM
BLSTIM==.MRUNT
;;; FORMAT OF SYMBOL HEADER FOR BIBOP:
;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE.
;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF
;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA.
;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST
;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF
;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE
;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO.
;;; THE SYMBOL BLOCK IS 2 WORDS LONG:
;;; <VARIOUS BITS>,,<POINTER TO VALUE CELL>
;;; <ARGS PROPERTY>,,<PNAME LIST>
;;; THE "VARIOUS BITS" ARE:
;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON)
;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK)
;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK)
;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL
;;; 3.6 UNUSED
;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE)
;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES,
;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS:
;;; 0 => NIL
;;; 777 => 777 (EFFECTIVELY INFINITY)
;;; N => N-1, N NOT 0 OR 777
;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777)
SPCBOT SAR
DEDSAR: 0,,ADEAD ;DEAD SAR (PROTECTED BY GC)
TTDEAD
UB.AC: 0,,ADEAD ;SAR FOR "UNBOUND" ARRAY
TTDEAD
DBM: 0,,ADEAD ;DEAD BLOCK MARKER
TTDEAD
BSYSAR==. ;BEGINNING OF "SYSTEM" ARRAY PROPS (SEE SYSP)
OBARRAY: AS<OBA+SX+GCP>,,IOBAR1 ;OBARRAY
TTS<1D+CN>,,IOBAR2(TT)
READTABLE: AS<RDT+FX>,,RSXTB1 ;READTABLE
TTS<1D+CN>,,RCT(TT)
PRDTBL: AS<RDT+FX>,,RSXTB2 ;PURE READTABLE
TTS<1D+CN>,,RCT0(TT)
IFN QIO,[
TTYIFA: AS<FIL+SX+GCP>,,TTYIF1 ;TTY INPUT FILE ARRAY
TTS<1D+CL+CN+TY>,,TTYIF2(TT)
TTYOFA: AS<FIL+SX+GCP>,,TTYOF1 ;TTY OUTPUT FILE ARRAY
TTS<1D+CL+CN+TY+IO>,,TTYOF2(TT)
INIIFA: AS<FIL+SX+GCP>,,INIIF1 ;INIT FILE ARRAY
TTS<1D+CL>,,INIIF2(TT)
] ;END OF IFN QIO
ESYSAR==.
SPCTOP SAR,ILS,[SAR]
;;; BEGINS ON A SEGMENT BOUNDARY, BECAUSE OF THE "SPCTOP SAR"
SPCBOT VC
C.==. ;LOCATION COUNTER FOR VALUE CELL SPACE
;;; NOTE THAT VALUE CELLS FOR T, NIL, UNBOUND, AND UBAR
;;; ARE IN PURE FREE STORAGE
BLOCK 400
SEGUP .
BXVCSG==.
IFN NXVCSG,[
PAGEUP
BXVCSG==.
LOC .+NXVCSG*SEGSIZ-1
PAGEUP
]
EVCSG==.
SPCBOT IS2
SY2ALC:
LOC .+2*LSYALC
SPCTOP IS2,ILS,[IMPURE SYMBOL BLOCK]
SPCBOT SYM
TRUTH: $$$TRUTH,,NIL ;ATOM HEADER FOR T
PUTOB TRUTH
ADDOB -.RL1+NIL,\KNOB
;;; CROCK TO PUTOB NIL CORRECTLY
;;; THESE FIVE SYMBOLS ARE **NOT** ON THE OBARRAY
QUNBOUND: $$$UNBOUND,,NIL ;INTERNAL UNBOUND MARKER
QUBAR: $$$UBAR,,$UBAR ;UNBOUND ARRAY, FOR USE BY *REARRAY
IFN EDFLAG,[
EDLP: $$$EDLP,,NIL
EDRP: $$$EDRP,,NIL
EDSTAR: $$$EDSTAR,,NIL
] ;END OF IFN EDFLAG
SYALC: BLOCK LSYALC ;FOR ALLOC
S.==. ;LOCATION COUNTER FOR SYMBOL SPACE
SEGUP BSYMSG+GSNSYSG*SEGSIZ-1
;END OF SYMBOL GUESS
ESYMGS==.
SUBTTL STARTS FOR SY2, PFX, AND PFS [PURE LIST] SPACES
10$ $HISEG
SPCBOT SY2
$$$TRUTH: 777300,,VTRUTH
0,,$$TRUTH
$$$UNBOUND: 777300,,SUNBOUND
0,,$$UNBOUND
$$$UBAR: 777300,,SUNBOUND
0,,$$UNBOUND ;MIGHT AS WELL GIVE UBAR THE PNAME "UNBOUND"
IFN EDFLAG,[
$$$EDLP: 777300,,SUNBOUND
0,,$$EDLP
$$$EDRP: 777300,,SUNBOUND
0,,$$EDRP
$$$EDSTAR: 777300,,SUNBOUND
0,,$$EDSTAR
] ;END OF IFN EDFLAG
B.==. ;LOCATION COUNTER FOR SYMBOL BLOCK SPACE
SEGUP BSY2SG+2*GSNSYSG*SEGSIZ-1
SPCBOT PFX
INR70: R70
F.==. ;LOCATION COUNTER FOR PURE FIXNUMS - USED FOR PNAMES AND INUMS
SEGUP BPFXSG+GSNPFXSG*SEGSIZ-1
EPFXGS==.
SPCBOT PFS
BPURFS==. ;BEGINNING OF PURE FS (FOR INSERT FILE PAGE)
;;; FREE STORAGE STUFF THAT IS NEVER GC'ED, NOR DARE MARKED FROM (NON-BIBOP)
$$UNBOUND:
APN UNBOUND
$UBAR:
QARRAY,,XUB.AC
XUB.AC: UB.AC,,NIL
$$NIL: ;PNAME FOR NIL
APN NIL
VNIL: NIL ;NIL'S VALUE CELL IS IN PFS - THAT WAY YOU CAN'T SETQ IT
$$TRUTH: ;PNAME OF T
APN T
VT:
VTRUTH: TRUTH ;LIKEWISE CAN'T SETQ T
;;; STANDARD UNBOUND VALUE CELL - POINTED TO BY ALL SYMBOLS WHICH
;;; DON'T HAVE THEIR OWN VALUE CELL. NOTE: ALL SUCH SYMBOLS ARE
;;; HELIOCENTRIC. MUST HAVE SUNBOUND ABOVE END OF VALUE CELL AREA
;;; - SEE GYSP5A AND SSYSTEM.
SUNBOUND: QUNBOUND
SSSBRL: QARRAY %
ASBRL: QAUTOLOAD %
SYSBRL: QARRAY,,SBRL
SBRL: QSUBR %
QFSUBR %
QLSUBR,,NIL
QGRTL: Q$GREAT,,NIL ;(>) FOR UGREAT
SUBTTL +INTERNAL FUNCTIONS AND INITIAL AUTOLOAD PROPERTIES
RDQTEB=RDQTE ;THE OTHERS WIN BECAUSE THEY ARE 6 CHARS
IRP X,,[RDQTE,RDSEMI,RDVBAR]Y,,[['],[;],[|]]
MKAT1 [+INTERNAL-Y-MACRO]SUBR,[ ]X!B
TERMIN
IFE QIO,[
MKAT1 +INTERNAL-TYO-MACRO,SUBR,[ ]TTYECOB
MKAT1 +INTERNAL-↑H-BREAK,SUBR,[ ]CN.HB
] ;END OF IFE QIO
IFN QIO,[
MKAT1 +INTERNAL-TTYSCAN-SUBR,SUBR,[ ]TTYBUF
MKAT1 +INTERNAL-↑Q-MACRO,SUBR,[ ]CTRLQ
MKAT1 +INTERNAL-↑S-MACRO,SUBR,[ ]CTRLS
MKAT1 +INTERNAL-↑B-BREAK,SUBR,[ ]CN.BB
MKAT1 +INTERNAL-IOL-BREAK,SUBR,[ ]IOLB
MKAT1 +INTERNAL-UREAD-EOFFN,SUBR,[ ]UREOF
MKAT1 +INTERNAL-TTY-ENDPAGEFN,SUBR,[ ]TTYMOR
] ;END OF IFN QIO
MKAT1 +INTERNAL-*RSET-BREAK,SUBR,[ ]CB
IRP X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC]
MKAT1 +INTERNAL-X-BREAK,SUBR,[ ]X!B
TERMIN
MKAT1 +INTERNAL-PDL-BREAK,SUBR,[ ]PDLB
MKAT1 +INTERNAL-GCO-BREAK,SUBR,[ ]GCOB
IFN NEWRD,[
;;;INITIAL ASSQ LIST OF MACRO-FUNCTIONS
PRMCLS: .+1,,.+2
47,,QRDQTE
.+1,,NIL
73,,QRDSEMI
] ;END OF IFN NEWRD
MKAT1 +INTERNAL-AUTOLOAD,SUBR,[ ]IALB
BSYSAP==. ;BEGINNING OF SYSTEM AUTOLOAD PROPERTIES
;;; NOTE THAT DUE TO THE 6-CHAR LOSS, GRINDEF HAD TO BECOME GFN IN THE LABEL
IRP A,,[GRIND,GFN,LAP,TRACE,GETMIDASOP,INDEX,SORT]B,,[GI,GE,LA,TR,GT,IN,SO]
QFL.!B: Q!A,,IRATBL
TERMIN
IFE EDFLAG, QFL.ED: QEDIT,,IRATBL
10% QFL.CG: QCGOL,,IRATBL
SA$ QFL.ER: QEREAD,,IRATBL
SA$ QFL.HE: QHELP,,IRATBL
IFN QIO,[
IFN USELESS, QFL.DA: QDUMPARRAYS,,IRATBL
QFL.MX: QMPX,,IRATBL
QFL.DS: QSLAVE,,IRATBL
QFL.NV: QNVID,,IRATBL
IFN USELESS, QFL.AL: QALLFILES,,IRATBL
] ;END OF IFN QIO
ESYSAP==. ;END OF SYSTEM AUTOLOAD PROPERTIES
IRATBL: QFASL % ;STANDARD DIRECTORY FOR SYSTEM AUTOLOAD FILES
IRACOM:
10% QCOM,,NIL ;COM DEVICE ON ITS (COMMON;)
SA% 10$ QSYS,,NIL ;SYS DEVICE ON DEC-10
SA$ QDSK % ;ON SAIL IT IS ... DSK (MAC LSP)
SA$ .+1,,NIL
SA$ QMAC %
SA$ QLSP,,NIL
QFASLL: QFASL,,NIL
SUBTTL RANDOM LIST STRUCTURE
IFN BIGNUM,[
BNM23A: IN0 %
IN1,,NIL
BNM23B: IN0 %
IN2,,NIL
BN.1A: IN0+1,,NIL
BNV2A: BNV1,,NIL
] ;END OF IFN BIGNUM
IFN EDFLAG,[
EDFUNL: QEXPR %
QFEXPR %
QMACRO,,NIL
$$EDLP:
APN [%I(%]
$$EDRP:
APN [%I)%]
$$EDSTAR:
APN [%D()%]
] ;END OF IFN EDFLAG
IFN QIO,[
QTLIST: TRUTH,,NIL
IFE D10,[
QLSPOUT: Q.LISP. % ;(/.LISP/. OUTPUT)
QOUTPUT,,NIL
QLSPAPP: Q.LISP. % ;(/.LISP/. APPEND)
QAPPEND,,NIL
] ;END OF IFE D10
QCOMDEV: IRACOM,,NIL ;((COM)) [FOR DEC-10, ((SYS))]
] ;END OF IFN QIO
Q% PSUDOSPACE: 203,,NIL ;WHEN RDIN WANTS TO RETURN ONE SPACE.
QUWL: QUWRITE,,NIL
QURL: QUREAD,,NIL
LGOR: QGO %
QRETURN,,NIL
QNILSETQ: QSETQ % ;FOR NIHIL ERROR MESSAGE
.+1,,NIL
NIL,,NIL
QTSETQ: QSETQ % ;FOR VERITAS ERROR MESSAGE
.+1,,NIL
TRUTH,,NIL
QXSETQ: QSETQ % ;FOR PURITAS ERROR MESSAGE
QXSET1,,NIL
ARQLS: QARRAY % ;(ARRAY ?)
$QMLST: QM,,NIL ;LIST OF A QUESTION MARK: (?)
QSJCL: QSTATUS % ;(STATUS JCL)
QJCL,,NIL
SPCNAMES:
REPEAT HNKLOG, CONC QHUNK,\.RPCNT+1,,,.+1
IRP XX,,[LIST,FIXNUM,FLONUM,BIGNUM,SYMBOL,ARRAY]FLG,,[1,1,1,BIGNUM,1,-1]
IFN FLG, Q!XX,,IFG FLG,[.+1]
TERMIN
PDLNAMES:
IRPS XX,Y,[REG FL FX SPEC]
Q!XX!PDL,,IFSE [Y][ ][.+1]
TERMIN
SUBTTL RANDOM SYSTEMIC ATOMS
;;; FOR BIBOP, (LIST, FIXNUM, FLONUM, BIGNUM, SYMBOL, <HUNKS>, RANDOM, ARRAY) MUST BE IN THAT ORDER
;;; (NOTE THAT THIS OVERLAPS THE NEXT LIST!)
COMMENT # QLIST: QFIXNUM: QFLONUM: QBIGNUM: QSYMBOL: QHUNK1: QRANDOM: QARRAY: #
MKAT LIST,LSUBR,[ ]
MSA FIXNUM,FIXNUM
MSA FLONUM,FLONUM
BG$ MSA BIGNUM,BIGNUM
MSA SYMBOL,SYMBOL
IRP X,,[4,8,16,32,64,128,256,512,1024]
IFE .IRPCNT-HNKLOG, .ISTOP
CONC MSA HUNK,\.IRPCNT+1,,HUNK!X
TERMIN
MKAT RANDOM,LSUBR,[ ]02
;;; (ARRAY, SUBR, FSUBR, LSUBR, EXPR, FEXPR, MACRO, AUTOLOAD) MUST BE IN THAT ORDER
MKAT ARRAY,FSUBR,[ ]
MKAT SUBR,SUBR,[ ]1
IRP A,,[FSUBR,LSUBR,EXPR,FEXPR,MACRO]
MSA A,A
TERMIN
Q% MSA AUTOLOAD,AUTOLOAD
;;; FOR QIO, (AUTOLOAD, ERRSET, *RSET-TRAP, GC-DAEMON,
;;; GC-OVERFLOW, PDL-OVERFLOW) MUST BE IN THAT ORDER
;;; NOTE THAT AUTOLOAD BELONGS TO SEQUENCE ABOVE ALSO
IFN QIO,[
MKAV AUTOLOAD,VAUTFN,QIALB,AUTOLOAD
MKFV ERRSET,ERRSET,FSUBR
MKAV *RSET-TRAP,V.TRAP,QCB,.R.TP
MKAV GC-DAEMON,VGCDAEMON
MKAV GC-OVERFLOW,VGCO,QGCOB,GCO
MKAV PDL-OVERFLOW,VPDL,QPDLB,PDL
] ;END OF IFN QIO
IRP A,,[VALUE,LAMBDA,SYM,DSK,SPLICING,SINGLE,EVALARG]
MSA A,A
TERMIN
IFN FUNAFL, MSA LABEL,LABEL
IFN FUNAFL, MSA FUNARG,FUNARG
10% MSA COM,COM
10$ MSA SYS,SYS
SA$ MSA MAC,MAC
SA$ MSA LSP,LSP
MSA BPS,BPS
MSA BIBOP,BIBOP
;;; (REGPDL, FLPDL, FXPDL, SPECPDL) MUST BE IN THAT ORDER
MSA REGPDL,REGPDL
MSA FLPDL,FLPDL
MSA FXPDL,FXPDL
MSA SPECPDL,SPECPDL
MSA FASL,FASL
10% MSA ITS,ITS
10$ MSA DEC10,DEC10
IFN USELESS, MSA ROMAN,ROMAN
MSA JCL,JCL
IFN SAIL+QIO, MSA SAIL,SAIL
IFN QIO,[
MSA FILE,FILE
IFN JOBQIO, MSA JOB,JOB
MSA ECHO,ECHO
MSA CLA,CLA
MSA RDEOF,READ-EOF
MSA IMAGE,IMAGE
MSA BLOCK,BLOCK
MSA CN.B,[↑B]
MSA NEWIO,NEWIO
MSA OUTPUT,OUTPUT
MSA .LISP.,.LISP.
MSA SLAVE,SLAVE
] ;END OF IFN QIO
MSA M,[?] ;FOR VARIOUS UNCERTAIN MESSAGES
MSA ..MIS,[**MISSING-ARG**]
MSA LA,[←]
MSA XPRHSH,EXPR-HASH
MSA LISP,LISP
MSA DDT,DDT
SUBTTL ATOMS FOR SUBRS
MKAT GC,SUBR,,0
MKAT1 ↑G,SUBR,,CTRLG,0
;;; MUST HAVE (RUNTIME, TIME) IN THAT ORDER
MKAT1 RUNTIME,SUBR,[ ]$RUNTIME,0
MKAT TIME,SUBR,[ ]0
MKFV CAR,CAR,SUBR,,1
MKFV CDR,CDR,SUBR,,1
IRPS A,C,[FIXP FLOATP RETURN EVALFRAME ERRFRAME,
BIGP,BOUNDP,LISTIFY
CAAR,CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,
CDDAR,CDDDR,CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,
CADDDR,CDAAAR,CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,
NOT,ATOM TYPEP,EXPLODE,MINUSP,PLUSP,NUMBERP ZEROP,
INTERN,LAST,REVERSE,NREVERSE,READLIST,MAKNAM,NCONS,
LENGTH,ABS,MINUS,ADD1,SUB1,FIX,FLOAT,
FLATSIZE,FLATC,ARG SIN,COS,SQRT,LOG,EXP,
SXHASH,NOINTERRUPT,REMOB,SYSP,MAKUNBOUND,IMPLODE,MUNKAM
MAKNUM,SYMEVAL,PLIST,PURCOPY]
MKAT A,SUBR,[C]1
TERMIN
MKAT1 SLEEP,SUBR,,$SLEEP,1
IFN USELESS, MKAT HAULONG,SUBR,,1
IFE QIO,[
MKAT1 TYI,LSUBR,[ ]%TYI,01
MKAT1 TYO,SUBR,[ ]%TYO,1
MKAT1 PRINT,SUBR,[ ]PRINT,1
MKAT1 PRINC,SUBR,[ ]PRINC,1
MKFV TERPRI,%TERPRI,SUBR,,0
MKFV PRIN1,PRIN1,SUBR,,1
MKAT ERRPRINT,SUBR,,1
MKFV READ,OREAD,LSUBR,,01
MKAT LISTEN,SUBR,,0
MKAV JPG|,VJPG ;***** CROCK FOR JPG *****
] ;END OF IFE QIO
IRPS A,C,[IFIX,EXPLODEC,NULL,ASCII ALLOC]
MKAT1 A,SUBR,[C]$!A,1
TERMIN
MKAT1 EXPLODEN,SUBR,,$$EXPLODEN,1
MKAT1 ARRAYDIMS,SUBR,,ADIMS,1
MKAT1 PNGET,SUBR,,$PNGET,2
IRPS A,C,[SUBLIS REMPROP SET,RPLACA,RPLACD,CONS,XCONS,
EQ,FRETURN,EXPT,MEMQ,SETARG MEMBER,EQUAL,GET,GETL,ASSOC,ASSQ,
REMAINDER,ATAN,SAMEPNAMEP,ALPHALESSP GETCHAR,COPYSYMBOL,PNPUT,
FILLARRAY NRECONC,SETPLIST]
MKAT A,SUBR,[C]2
TERMIN
MKAT1 GETCHARN,SUBR,,$GETCHARN,2
IFN HNKLOG,[
MKAT CXR,SUBR,,2
MKAT MAKHUNK,SUBR,[ ]1
MKAT HUNKP,SUBR,,1
MKAT HUNKSIZE,SUBR,,1
MKAT HUNK,LSUBR,[ ]
MKAT RPLACX,SUBR,,3
] ;END OF IFN HNKLOG
IFN USELESS,[
MKAT1 [\\]SUBR,,.GCD,2
IRPS A,C,[RECLAIM,HAIPART,GCD]
MKAT A,SUBR,[C]2
TERMIN
]
IFN USELESS*<1-QIO>,[
MKAT DUMPARRAYS,SUBR,,2
MKAT LOADARRAYS,SUBR,,1
] ;END OF IFN USELESS*<1-QIO>
IRPS A,,[LSH,ROT,FSC]
MKAT1 A,SUBR,,$!A,2
TERMIN
MKAT1 ↑,SUBR,,XPTII,2
MKAT1 ↑$,SUBR,,XPTI$,2
MKAT1 *BREAK,SUBR,,$BREAK,2
IRPS A,,[DIF,QUO]
MKAT1 [*A]SUBR,,.!A,2
TERMIN
IRP A,,[1+,1-]B,,[ADD1,SUB1]
IRP C,,[$,]D,,[$,I]
MKAT1 [A!!C]SUBR,,[D!!B]1
TERMIN
TERMIN
IRP A,,[>,<]B,,[GREAT,LESS]
MKAT1 A,SUBR,[ ]$!B,2
TERMIN
MKAT1 =,SUBR,,$EQUAL,2
MKAT1 [\]SUBR,,REMAINDER,2
IRPS A,C,[SASSOC,SASSQ,SETSYNTAX,SUBST]
MKAT A,SUBR,[C]3
TERMIN
MKFV PUTPROP,PUTPROP,SUBR,SBRL,3
IFN USELESS*ITS, MKAT1 PURIFY,SUBR,,$PURIFY,3
SUBTTL ATOMS FOR FSUBRS AND LSUBRS
IRPS A,C,[COND PROG QUOTE DO DECLARE PROGV,
DEFPROP CATCH THROW BREAK GO ,
SETQ ERR SIGNP STORE STATUS SSTATUS FUNCTION ]
MKAT A,FSUBR,[C]
TERMIN
IFE QIO,[
IRPS A,C,[CRUNIT UKILL UREAD UWRITE UFILE UCLOSE UAPPEND ,
UPROBE IOC IOG ]
MKAT A,FSUBR,[C]
TERMIN
] ;END OF IFE QIO
MKFV DEFUN,DEFUN,FSUBR,NIL
MKAT1 COMMENT,FSUBR,[ ]$COMMENT
MKAT1 AND,FSUBR,,$AND
MKAT1 OR,FSUBR,,$OR
IFN FUNAFL, MKAT1 *FUNCTION,FSUBR,[ ]%%FUNCTION
;;; MUST HAVE (MAPLIST,MAPCAR,MAP,MAPC,MAPCON,MAPCAN) IN THAT ORDER
MKAT MAPLIST,LSUBR,[ ]2777
MKAT MAPCAR,LSUBR,[ ]2777
MKAT MAP,LSUBR,[ ]2777
MKAT MAPC,LSUBR,[ ]2777
MKAT MAPCON,LSUBR,[ ]2777
MKAT1 MAPCAN,LSUBR,[ ]$MAPCAN,2777
MKAT PROG2,LSUBR,[ ]2777
MKAT PROGN,LSUBR
MKAT BOOLE,LSUBR,,2777
IRPS A,C,[DELQ DELETE APPLY ]
MKAT A,LSUBR,[C]23
TERMIN
10% MKAT SYSCALL,LSUBR,[ ]3777
MKAT FUNCALL,LSUBR,[ ]1777
MKAT1 ARRAYCALL,FSUBR,[ ]%ARRAYCALL
MKAT SUBRCALL,FSUBR,[ ]
MKAT1 LSUBRCALL,FSUBR,[ ]%LSUBRCALL
IRPS A,C,[VALRET BAKTRACE BAKLIST SUSPEND GENSYM ]
MKAT A,LSUBR,[C]01
TERMIN
Q% MKAT TYIPEEK,LSUBR,[ ]01
IFN USELESS*ITS,[
Q$ MKAT CURSORPOS,LSUBR,[ ]03
Q% MKAT CURSORPOS,LSUBR,[ ]02
] ;END OF IFN USELESS*ITS
MKAT1 ERROR,LSUBR,[ ]$ERROR,03
MKAT GETSP,LSUBR,[ ]12
MKAT MAPATOMS,LSUBR,[ ]12
IRPS A,C,[NCONC PLUS,TIMES,DIFFERENCE,QUOTIENT,APPEND ]
MKAT A,LSUBR,[C]
TERMIN
;;; MUST HAVE (MAX,GREATERP,MIN,LESSP) IN THAT ORDER
MKAT MAX,LSUBR,[ ]1777
MKAT GREATERP,LSUBR,[ ]2777
MKAT MIN,LSUBR,[ ]1777
MKAT LESSP,LSUBR,[ ]2777
;;; IN THE FOLLOWING, NOTE THAT +, -, *, AND / GET VALUE CELLS
IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT]
MKFV [A]I!B,LSUBR,QI!B
TERMIN
IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT]
MKAT1 [A!$]LSUBR,,[$!B]
TERMIN
;;; THESE FOUR MUST BE IN THIS ORDER!
.SEE UINT32
MKAT ODDP,SUBR,[ ]1
MKFV EVAL,OEVAL,LSUBR,NIL,12
MKAT DEPOSIT,SUBR,[ ]2
MKAT EXAMINE,SUBR,[ ]1
MKAT1 READCH,LSUBR,[ ]$READCH,01
MKAT1 *REARRAY,LSUBR,[ ].REARRAY,16
MKAT1 *ARRAY,LSUBR,[ ]%%ARRAY,27
MKAT LISTARRAY,LSUBR,[ ]12
SUBTTL ATOMS FOR LAP, FASLAP, AND FASLOAD USAGE
;;; SUBROUTINES USED BY COMPILER OUTPUT - ERGO, NEEDED BY LAP
;;; AND FASLOAD. ALSO OTHER GOODIES FOR LAP AND FASLAP.
IRP A,,[DELQ,DELETE,APPEND,TIMES,GREAT,LESS,PLUS,NCONC,APPLY]
MKAT1 *A,SUBR,[ ].!A,2
TERMIN
IRP A,,[PRINT,PRIN1,PRINC,TERPRI,TYO]B,,[PRT,PR1,PRC,TRP,TYO]C,,[1,1,1,0,1]
Q$ MKAT1 *!A,SUBR,[ ]B!$,C
Q% MSA B!$,*!A
TERMIN
MKAT1 *EVAL,SUBR,,EVAL,1
MKAV PURE
MKAV *PURE,V.PURE
MKAV PURCLOBRL
MKAT1 FASLAPSETUP|,SUBR,,FSLSTP,1
MKFV LAPSETUP|,LAPSETUP,SUBR,1
MKAT PAGEBPORG,SUBR,[ ]0
MKFV TTSR|,TTSR,SUBR
MKAT1 SQOZ|,SUBR,,5BTWD,1
MKAT GETDDTSYM,SUBR,[ ]1
MKAT PUTDDTSYM,SUBR,,2
MKFV GCPROTECT,GCPRO,SUBR,2
MKAV SYMBOLS,V$SYMBOLS,,$SYMBOLS
MKFV FASLOAD,FASLOAD,FSUBR,TRUTH
MKAT2 GRINDEF,GE,GFN
MKAT2 GRIND0,GI,GR0
IRPS A,,[SPRINTER,GRIND,GETMIDASOP,LAP,TRACE,INDEX,SORT,SORTCAR]B,,[GE,GI,GT,LA,TR,IN,SO,SO]
MKAT2 A,B
TERMIN
10% MKAT2 CGOL,CG
10% MKAT2 CGOLREAD,CG
SA$ MKAT2 EREAD,ER
SA$ MKAT2 HELP,HE
IFN QIO*USELESS,[
IRP A,,[DUMPARRAYS,LOADARRAYS,ALLFILES,MAPALLFILES,DIRECTORY,MAPDIRECTORY]B,,[DA,DA,AL,AL,AL,AL]
MKAT2 A,B
TERMIN
] ;END OF IFN QIO*USELESS
SUBTTL ATOMS FOR ODDBALL FUNCTIONS AND VARIABLES
IFN SAIL+ITS, MKFV ALARMCLOCK,ALARMCLOCK,SUBR,,2
IFE SAIL+ITS, VALARM==VNIL
IFN QIO*USELESS,[ ;THESE MUST BE IN THIS ORDER, FOLLOWNG ALARMCLOCK
MKAV CLI-MESSAGE,VCLI,,CLI
MKAV MAR-BREAK,VMAR,,MAR
MKAV TTY-RETURN,VTTR,,TTR
MKAV SYS-DEATH,VSYSD,,SYSD
] ;END OF IFN QIO*USELESS
MKFV NOUUO,NOUUO,SUBR,,1
MKFV NORET,NORET,SUBR,,1
Q% MKFV ERRSET,ERRSET,FSUBR
MKFV EVALHOOK,EVALHOOK,LSUBR,,23
MKFV GCTWA,GCTWA,FSUBR
MKFV ARGS,ARGS,LSUBR,,12
MKFV *RSET,.RSET,SUBR,,1
MKFV *NOPOINT,.NOPOINT,SUBR,,1
MKFV OBARRAY,OBARRAY,ARRAY,OBARRAY
MKFV READTABLE,READTABLE,ARRAY,READTABLE
IFN EDFLAG,[
MKFV EDIT,EDIT,FSUBR,EDFUNL
MKAV [≠≠≠]VDLDLDL
MKAV [≠≠]VDOLLAR,,DOLLAR
] ;END OF IFN EDFLAG
IFE EDFLAG, MKAT2 EDIT,ED
IFN QIO,[
SUBTTL ATOMS FOR NEWIO FUNCTIONS AND VARIABLES
IRPS A,C,[NAMELIST,NAMESTRING,SHORTNAMESTRING,TRUENAME,
INPUSH,PROBEF,LOAD ]
MKAT A,SUBR,[C]1
TERMIN
MKFV DEFAULTF,DEFAULTF,SUBR,,1
MKAT1 FORCE-OUTPUT,SUBR,[ ]FORCE,1
MKAT1 CLEAR-OUTPUT,SUBR,,CLROUT,1
MKAT1 CLEAR-INPUT,SUBR,,CLRIN,1
IRPS A,C,[CLOSE DELETEF IN FASLP ]
MKAT1 A,SUBR,[C]$!A,1
TERMIN
MKAT1 OPEN,LSUBR,[ ]$OPEN,04
MKAT1 OUT,SUBR,[ ]$OUT,2
MKAT1 RENAME,SUBR,[ ]$RENAME,2
MKAT MERGEF,SUBR,,2
MKAT1 LISTEN,LSUBR,[ ]$LISTEN,01
IRPS A,C,[CRUNIT,UKILL,UFILE UCLOSE,UAPPEND,UPROBE,INCLUDE]
MKAT A,FSUBR,[C]
TERMIN
MKFV UREAD,UREAD,FSUBR
MKFV UWRITE,UWRITE,FSUBR
IRPS A,,[INFILE,MSGFILES,INSTACK,OUTFILES,ECHOFILES]C,,[TRUTH,QTLIST,,,]
MKAV A,,C
TERMIN
MKFV TYI,%TYI,LSUBR,TTYIFA,02
MKAT1 READLINE,LSUBR,[ ]%READLINE,02
MKAT TYIPEEK,LSUBR,[ ]03
MKFV TYO,%TYO,LSUBR,TTYOFA,12
MKAT1 PRINT,LSUBR,[ ]%PRINT,12
MKFV PRIN1,%PR1,LSUBR,,12
MKAT1 PRINC,LSUBR,[ ]%PRC,12
MKFV TERPRI,%TERPRI,LSUBR,,01
MKFV READ,OREAD,LSUBR,,02
IRPS A,C,[ENDPAGEFN EOFFN PAGEL CHARPOS LINENUM PAGENUM LINEL RUBOUT FILEPOS ERRPRINT ]
MKAT A,LSUBR,[C]12
TERMIN
] ;END OF IFN QIO
SUBTTL ATOMS FOR VARIABLES AND USER INTERRUPT BREAKS
;;; TTYOPN WILL INIT VLINEL TO THE RIGHT THINGS.
;;; FOR NON-BIBOP, NOTE THAT LINEL AND CHRCT POINT INTO THE
;;; (UNRELOCATED!) INUM AREA DURING ALLOC. THEY WILL THUS
;;; HAVE THE RIGHT VALUES BUT THE WRONG TYPE (I.E. TYPEP
;;; OF THEM WOULD LOSE.) THUS PRINT ETC. SHOULD NOT CHECK
;;; TYPEP OF THESE THINGS. ALLOC REHACKS THEIR VALUES AFTERWARDS.
;;; CHRCT IS INITIALLY 777 SO ALLOC WON'T GENERATE CR'S.
IRP A,,[BPEND,BPORG,ERRLIST,TTY,ZUNDERFLOW]C,,[VBPE1,VBP1,,,]
MKAV A,,C,A
TERMIN
BG$ MKAV ZFUZZ,,,ZFUZZ
Q% MKAV CHRCT,,IN777,CHRCT
Q% MKAV LINEL,,IN777,LINEL
;;; FOR NON-BIBOP, ALLOC REHACKS VBASE AND VIBASE AFTERWARDS.
MKAV IBASE,,IN10,IBASE
MKAV BASE,,IN10,BASE
IFN USELESS,[
MKAV PRINLEVEL,V%LEVEL,,%LEVEL
MKAV PRINLENGTH,V%LENGTH,,%LENGTH
] ;END OF IFN USELESS
IRP A,,[↑Q,↑W,↑R,↑A]B,,[TAPRED,TTYOFF,TAPWRT,SIGNAL]
MKAV A,B
TERMIN
Q% MKAV ↑B,LPTON
SA% MKAV [≠P]VDOLLRP,DOLLRP,DOLLRP
SA$ MKAV [}P]VDOLLRP,DOLLRP,DOLLRP
MKAV ↑D,GCGAGV,,CN.D
Q% MKAV ↑H,VCN.H,QCN.HB,CN.H
;;; FOR NON-QIO, (UNDF-FNCTN, UNBND-VRBL, WRNG-TYPE-ARG,
;;; UNSEEN-GO-TAG, WRNG-NO-ARGS, GC-LOSSAGE, FAIL-ACT)
;;; MUST BE IN THAT ORDER
;;; FOR QIO, (UNDF-FNCTN, UNBND-VRBL, WRNG-TYPE-ARG,
;;; UNSEEN-GO-TAG, WRNG-NO-ARGS, GC-LOSSAGE, FAIL-ACT,
;;; IO-LOSSAGE) MUST BE IN THAT ORDER
IRP A,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC]PN,,[UNDF-FNCTN,UNBND-VRBL
WRNG-TYPE-ARG,UNSEEN-GO-TAG,WRNG-NO-ARGS,GC-LOSSAGE,FAIL-ACT]
MKAV PN,V!A,Q!A!B,A
TERMIN
Q% MKAV PDL-OVERFLOW,VPDL,QPDLB,PDL
Q% MKAV GC-OVERFLOW,VGCO,QGCOB,GCO
Q$ MKAV IO-LOSSAGE,VIOL,QIOLB,IOL
Q% MKAV GC-DAEMON,VGCDAEMON
Q% MKAV *RSET-TRAP,V.TRAP,QCB,.R.TP
MKAV COMPILER-STATE,VCOMST
Q$ MKAV MACHINE-ERROR,VMERR,,MERR
IFN MOBIOF,[
SUBTTL ATOMS FOR MOBY I/O FUNCTIONS
MKAT NEXTPLOT,SUBR,,0
IRPS A,C,[IMPX PLOT PLOTTEXT]
MKAT A,SUBR,[C]1
TERMIN
IRPS A,C,[OMPX MPX NVFIX NVID ]
MKAT A,SUBR,[C]2
TERMIN
MKAT NVSET,SUBR,,5
MKAT PLOTLIST,LSUBR,[ ]12
IRP A,,[DISCOPY,DISCRIBE,DISGORGE,DISGOBBLE,DISFRAME]
MKAT A,SUBR,,1
TERMIN
IRPS A,C,[DISBLINK,DISPLAY DISMARK]
MKAT A,SUBR,[C]2
TERMIN
IRP A,,[DISLINK,DISCHANGE,DISLOCATE]
MKAT A,SUBR,,3
TERMIN
MKAT DISMOTION,SUBR,,4
MKAT DISFLUSH,LSUBR
MKAT DISINI,LSUBR,,02
MKAT DISLIST,LSUBR,,01
MKAT DISCREATE,LSUBR,,02
MKAT DISAPOINT,LSUBR,,34
MKAT DISALINE,LSUBR,,35
MKAT DISCUSS,LSUBR,,45
MKAT DISET,LSUBR,,13
MKAV ↑F,DISON,,CN.F
MKAV ↑N,DISPON,,CN.N
] ;END OF IFN MOBIOF
IFN QIO*ITS,[
IRP A,,[MPX,PLOT,PLOTLIST,NVID,NVFIX,NVSET,DISINI]B,,[MX,MX,MX,NV,NV,NV,DS]
MKAT2 A,B
TERMIN
MKAT2 SFTV|,NV,SFTV.
] ;END OF IFN QIO
PGTOP ATM,[SYSTEM ATOMS AND STUFF]
;;; ************* END OF PURE LISP (NON-BIBOP) *************
PFSLAST==. ;GUARANTEED SAFE OVER SPCTOP
10$ $LOSEG
LOC C.
ESYSVC==.
EXPUNGE C.
SUBTTL RANDOM BINDABLE CELLS
;;; HERE ARE THINGS WHICH ARE LIKE VALUE CELLS, IN THAT SPECPDL
;;; UNBINDING MUST WORK ON THEM; BUT THEY ARE NOT NECESSARILY
;;; MARKED FROM.
LISAR: NIL ;LAST INTERPRETIVELY-SEEN ARRAY - ASAR
IFE QIO,[
VCN.AT: NIL ;INTERRUPT FUN FOR ↑@
VICA: NIL ; " ↑A
VIC34: NIL ; " ↑\
VIC35: NIL ; " CONTROL RIGHT BRACKET
VIC36: NIL ; " ↑↑
VAUTFN: QIALB ;AUTOLOAD FUNCTION
] ;END OF IFE QIO
IFE QIO,[
TYIMAN: NIL ;IT'S....... TYI-MAN!
;FASTER THAN A SPEEDING IMLAC!
;MORE POWERFUL THAN A TECOMOTIVE!
;ABLE TO LEAP TALL FUNCTIONS WITH A SINGLE JRST!
;YES, IT'S TYI-MAN! WHO, IN HIS NORMAL IDENTITY AS
; CLARK NIL (A NAMELESS NOBODY), IS EVER-READY TO
; ASSUME A SECRET SUPER-IDENTITY TO PROTECT AND SERVE
; FREEDOM, JUSTICE, AND THE HIRSUTE READER!!!!!!!!
TMBBC: 0 ;ROBIN, TYIMAN'S BIRD-BRAINED COMPANION!
;WOULD YOU BELIEVE TYIMAN'S BUFFERED-BACK CHARACTER?
] ;END OF IFE QIO
IFN QIO,[
TYIMAN: $DEVICE ;WHERE TO GET CHARACTERS FROM
UNTYIMAN: UNTYI ;WHERE TO PUT BACK CHARACTERS TO
UNREADMAN: .+1
.VALUE
; UNRD ;WHERE TO PUT BACK FORMS TO
READPMAN: .+1
.VALUE
; READP ;WHERE TO GO TO CHECK FOR PENDING FORMS
] ;END OF IFN QIO
FASLP: NIL ;FASLOADING-P?
TIRPATE: 0 ;PSEUDO VALUE CELL, USED TO EXTIRPATE THE CONSEQUENT UNBINDING
;FOLLOWING A SETQ DONE ON NIL OR T
;;; #### MOOOBY IMPORTANT! MUST HAVE <ADDRESS OF ARGNUM> = <ADDRESS OF ARGLOC> + 1
ARGLOC: 0 ;FOR LEXPRS - LOCATION OF ARG VECTOR ON PDL
ARGNUM: 0 ;HOLDS FIXNUM WHICH IS # OF ARGS FOR LEXPR IN ARGLOC
SUBTTL BIBOP STORAGE PARAMETER CALCULATIONS
BFVCS:
INFVCS==BXVCSG-BFVCS
IFL INFVCS, WARN \-INFVCS,[=TOO MANY VALUE CELLS]
SPCTOP VC,ILS,[VALUE CELL]
LOC S.
EXPUNGE S. B.
IFL ESYMGS-1-., WARN \.-ESYMGS,[=TOO MANY SYMBOLS (SYMEST=]\SYMEST,[)]
SPCTOP SYM,ILS,[SYMBOL HEADER]
IFE ITS,[
NXXASG==0
NXXZSG==0
$HISEG
]
.ELSE,[
BXXASG==.
NXXASG==<<<BXXASG+PAGSIZ-1>&PAGMSK>-BXXASG>/SEGSIZ
BXXZSG==BXXASG+NXXASG*SEGSIZ ;TAKE UP SLACK PAGES BEFORE SY2
NXXZSG==<BSY2SG-BXXZSG>/SEGSIZ
] ;END OF IFE D10
NSY2SG==<BPFXSG-BSY2SG>/SEGSIZ
SEGUP BSY2SG+NSY2SG*SEGSIZ-1
SPCTOP SY2,ILS,[PURE SYMBOL BLOCK]
LOC F.
EXPUNGE F.
IFL EPFXGS-1-HINUM-LONUM-., WARN \.+HINUM+LONUM-EPFXGS,[=TOO MANY PURE FIXNUMS (PFXEST=]\PFXEST,[)]
ZZ==EPFXGS-.
ZZZ==<ZZ-HINUM-LONUM>/2 ; THEN TO THE NEXT PAGE BOUNDARY
XHINUM==HINUM+ZZZ ;DISTRIBUTE ANY SUCH EXTRA SPACE EVENLY
IFL XHINUM-777,XHINUM==777 ;MANY LOSERS DEPEND ON HINUM BEING AT LEAST THIS BIG
XLONUM==ZZ-XHINUM ; BETWEEN POSITIVE AND NEGATIVE INUMS
IFL XLONUM-10,[
WARN [XLONUM=]\XLONUM,[, YOU WILL CERTAINLY LOSE]
.ERR INUM LOSSAGE
]
REPEAT XLONUM, .RPCNT-XLONUM
IN0: ;HAIRY PAGE (APPROXIMATELY) OF SMALL FIXNUMS
REPEAT XHINUM, .RPCNT
IRP X,,[1,2,3,4,5,6,7,10,777]
IN!X=IN0+X
TERMIN
INFORM [HIGHEST NLISP INUM=]\XHINUM
INFORM [LOWEST NLISP INUM=-]\XLONUM
SPCTOP PFX,ILS,[PURE FIXNUM]
LOC PFSLAST
SPCTOP PFS,ILS,[PURE LIST]
SPCBOT PFL
;;; INITIAL ASSEMBLED PURE FLONUMS GO HERE (HA HA!)
SPCTOP PFL,ILS,[PURE FLONUM]
10$ $LOSEG
SUBTTL INITIAL RANDOM IMPURE FREE STORAGE
IFN ITS,[
BXXPSG==. ;POSSIBLE SLACK PURE SEGMENT
PAGEUP
NXXPSG==<.-BXXPSG>/SEGSIZ
SPCBOT IFS
NPURFS==<.-BPURFS>/PAGSIZ
] ;END OF IFN ITS,
.ELSE, SPCBOT IFS
FIRSTW:
QXSET1: .,,NIL ;FOR XSETQ
NUNMRK==.-FIRSTW .SEE GCP6
IFG NUNMRK-40, WARN \NUNMRK,[=TOO MANY UNMARKABLE FS LOCATIONS]
FEATLS: ;INITIAL LIST FOR (STATUS FEATURES)
QBIBOP %
IFN BIGNUM, QBIGNUM %
IFN EDFLAG, QEDIT %
QFASLOAD %
IFN HNKLOG, QHUNK %
IFN FUNAFL, QFUNARG %
IFN USELESS, QROMAN %
IFN QIO, QNEWIO %
IFN MOBIOF, QCN.F %
10% MACHFT: NIL % ;STARTUP PUTS MACHINE NAME HERE
10% QITS,,NIL
SA% 10$ QDEC10,,NIL ;SAIL
SA$ QDEC10 %
SA$ QSAIL,,NIL ;(STATUS FEATURES) FOR SAIL
; - THERE IS SOME FENCE POST ERROR . . .
BPROTE:
BG$ BNV1,,ARGNUM ;TO PROTECT CONTENTS OF THESE CELLS
BG% NIL,,ARGNUM
TLF: NIL ;TOP LEVEL FORM - NIL FOR STANDARD
BLF: NIL ;ANALOGOUSLY, THE BREAK LEVEL FORM
QF1SB: NIL ;SAVE B DURING QF1
PA3: 0 ;RH = PROG BODY (I.E. CDDR OF PROG FORM)
;LH = NEXT PROG STATEMENT
GCPSAR: 0 ;POINTS TO SAR FOR HASH ARRAY FOR GC-PROTECTION LISTS
IFE QIO,[
RDTYBF: 0 ;SIMULATED TTY BUFF (FS LIST)
MKNM3: NIL ;HOLDS LIST OF CHARS TO BE READLISTED
URUNIT: NIL ;LAST ARG TO UREAD
UWUNIT: NIL ;LAST ARG TO UWRITE
IUNIT: NIL ;"CRUNIT"
] ;END OF IFE QIO
Q$ RDLARG: NIL ;LIST OF CHARS FOR READLIST, MAKNAM, IMPLODE
IFN EDFLAG,[
EDUPLST: NIL ;UP POINTER LIST FOR EDIT
EDSRCH: NIL ;SAVED SEARCH LIST
] ;END OF IFN EDFLAG
IFN MOBIOF, FTVU: NIL ;IF FAKE TV IS IN USE, HAS (G0001 DSK VIS) ?
IFN MOBIOF, FTVBL: NIL ;LIST OF BLOCKS CURRENTLY RESIDENT IN BUFFERS - LAST OF LIST IN LH
LDFNAM: NIL ;FASLOAD FILE NAME
SUDIR: NIL ;INITIAL SNAME (ITS) OR PPN (DEC-10)
FEATURES: FEATLS
LDEVPRO: NIL ;LIST OF EVALED-FROBS-IN-ATOMTABLE TO BE PROTECTED
NILPROPS: NIL ;PROPERTY LIST FOR NIL
IFN QIO,[
DEOFFN: NIL ;DEFAULT EOF FUNCTION
DENDPAGEFN: NIL ;DEFAULT END OF PAGE FUNCTION
] ;END OF IFN QIO
LPROTE==.-BPROTE
Q.=QITIMES ;ALIASES FOR THE SYMBOL *
V.=VITIMES
IFN EDFLAG, DOLLAR=QDOLLAR
DOLLRP=QDOLLRP
Q% IGCMKL==NIL ;INITIAL GCMKL
IFN QIO,[ ;INITIAL GCMKL
IGCMKL: DEDSAR % ;DEAD AREA AT TOP OF BPS
IGCFX1 %
INIIFA % ;INIT FILE ARRAY
IGCFX2,,NIL
] ;END OF IFN QIO
OBTFS: BLOCK KNOB+10 ;FREE STORAGE FOR OBARRAY CONSAGE
LFSALC==100
FSALC: BLOCK LFSALC ;FOR ALLOC
SPCTOP IFS,ILS,[IMPURE LIST]
SPCBOT IFX
BG$ BNV1: . ;TEMPORARILY RPLACED BY BNCVTM
VBP1: ;INITIAL ALLOCATED VALUE FOR BPORG
BBPSSG
VBPE1: ;INITIAL ALLOCATED VALUE FOR BPEND
Q% 10% <<ENDLISP+PAGSIZ-1>&PAGMSK>-1
Q% 10$ ENDLISP
Q$ INIIF1-2
IFN QIO,[
IGCFX1: <<ENDLISP+PAGSIZ-1>&PAGMSK>-EINIFA ;SIZE OF DEAD BLOCK
IGCFX2: LINIFA ;SIZE OF INIT FILE ARRAY
] ;END OF IFN QIO
LFWSALC==40
FWSALC: BLOCK LFWSALC ;FOR ALLOC
NIFWAL==0
SPCTOP IFX,ILS,[IMPURE FIXNUM]
SPCBOT IFL
0 ;NEED AT LEAST ONE IMPURE FLONUM SEGMENT
SPCTOP IFL,ILS,[IMPURE FLONUM]
IFN BIGNUM,[
SPCBOT BN
BBIGPRO: ;PROTECTED BIGNUMS
BN235: 0,,BNM23A
BNM235: -1,,BNM23A
BNM236: -1,,BNM23B
BNV2: 0,,BNV2A
BN.1: 0,,BN.1A
LBIGPRO==.-BBIGPRO
SPCTOP BN,ILS,[BIGNUM]
] ;END OF IFN BIGNUM
IFE BIGNUM,[
BBNSG==.
NBNSG==0
] ;END OF IFE BIGNUM
IFE D10,[
BXXBSG==. ;TAKE UP SLACK UNTIL FIRST PAGE OF BPS
PAGEUP
NXXBSG==<.-BXXBSG>/SEGSIZ
] ;END OF IFE D10
IF2 GEXPUN
BLSTIM==.MRUNT-BLSTIM
INFORM [TIME TO MAKE INITIAL STRUCT, PASS ]\.PASS,[ = ]\BLSTIM/1000.,[ SECS]
;;@ END OF STRUCT 204
;;; 10$ NOW IN ** LOW SEGMENT **
NBITB==NIFSSG+NIFXSG+NIFLSG+NBNSG
ZZ==<<NBITB+1>*BTBSIZ+SEGSIZ-1>/SEGSIZ
IFN ZZ-BTSGGS,[
WARN [NEEDED NUMBER OF INITIAL BIT TABLE SEGMENTS (]\ZZ,[) DOESN'T
MATCH GUESS. (BTSGGS=]\BTSGGS,[)
]
] ;END OF IFN ZZ-BTSGGS
.ALSO .ERR
IFN LOBITSG, BFBTBS=BTBLKS+NBITB*BTBSIZ
.ELSE,[ ;;; NOTE WELL! FIRST FS SEGMENT GETS FIRST
;;; BIT BLOCK! (SEE NUNMRK, GCP6)
SPCBOT BIT
BTBLKS: BLOCK NBITB*BTBSIZ
BFBTBS: ;BEGINNING OF FREE BIT BLOCKS
PAGEUP
SPCTOP BIT,ST,[BIT BLOCK]
] ;END OF .ELSE
NBPSSG==1*SGS%PG ;INIT WILL MUNG ST AND PURTBL ANYWAY TO PRESERVE ALLOC
NFXPSG==1*SGS%PG ;PDL AREAS FOR INIT AND ALLOC
NFLPSG==1*SGS%PG
NPSG==1*SGS%PG
NSPSG==1*SGS%PG ;ALLOC ALTERS ALL PDL PARAMETERS!!!
IFN ITS,[
NXFXPSG==1*SGS%PG
NXFLPSG==1*SGS%PG
NXPSG==1*SGS%PG
NXSPSG==1*SGS%PG
IFN ML+QIO, NSCRSG==2*SGS%PG
.ELSE NSCRSG==3*SGS%PG ;ALLOW FOR PDP6 PAGE (P6)
;;; NUMBER OF NON-EXISTENT MEMORY SEGMENTS
;;; (TAKE ALL OF CORE AND SUBTRACT OUT EVERYTHING USEFUL!!!)
NNXMSG==NSEGS
IRP SPC,,[ZER,ST,SYS,SAR,VC,XVC,IS2,SYM,XXA,XXZ,SY2,PFX,PFS,PFL,XXP
IFS,IFX,IFL,BN,XXB,BIT,BPS,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
NNXMSG==NNXMSG-N!SPC!SG
TERMIN
;;; DETERMINE ORIGINS FOR ALL SPACES ABOVE THIS POINT
ZZX==.
IRP SPC,,[BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==MEMORY-<NSCRSG+NSPSG+NXSPSG>*SEGSIZ
PDLORG==SPDLORG-<NPSG+NXPSG>*SEGSIZ
FLPORG==PDLORG-<NFLPSG+NXFLPSG>*SEGSIZ
FXPORG==FLPORG-<NFXPSG+NXFXPSG>*SEGSIZ
] ;END OF IFN ITS
IFE ITS,[
ZZX==.
IRP SPC,,[FXP,FLP,P,SP,BPS]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==BSPSG
PDLORG==BPSG
FLPORG==BFLPSG
FXPORG==BFXPSG
] ;END OF IFE ITS
SUBTTL APOCALYPSE (END OF THE WORLD)
;FOR REL ASSEMBLIES, INIT AND ALLOC CODE OVERLAP INITIAL BPS
IFE ITS, LOC BBPSSG
;;@ ALLOC 92 INITIALIZATION AND ALLOCATION ROUTINES
SUBTTL INITIALIZATION CODE
;;; THIS CODE IS IN BINARY PROGRAM SPACE
.CRFOFF
OBTL: REPEAT KNOB, CONC OBT,\.RPCNT
.CRFON
INIT:
IFN D10,[
DINIT==.
SETZ FREEAC,
SETUWP FREEAC, ;FREEAC HAS OLD STATE OF HISEG-PURE BIT
.VALUE
] ;END OF IFN D10
IFN ITS,[
MOVE TT,[4400,,400000+<<PDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<SPDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FXPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
] ;END OF IFN ITS
MOVE P,C2
MOVE SP,SC2
MOVE FXP,FXC2
;;; (SETPLIST '*PRINT (PLIST 'PRINT)), ETC.
IFE QIO,[
IRP A,,[PRINT,PRIN1,PRINC,%TERPRI,%TYO]B,,[PRT,PR1,PRC,TRP,TYO]
HRRZ F,Q!A
HRRM F,Q!B!$
TERMIN
] ;END OF IFE QIO
;;; FALLS THROUGH
;;; FALLS IN
INIBS: MOVEI F,0 ;BUBBLE-SORT THE LAPFIV TABLE, WHILE
MOVEI C,LLSYMS-1 ;SORTING THE BSP TABLE AS SUBSIDIARY RECORDS
INIBS1: MOVE D,LAPFIV(C)
CAML D,LAPFIV-1(C)
JRST INIBS2
MOVEI F,1 ;FLAG TO NOTE THAT A BUBBLING OCCURED THIS PASS
EXCH D,LAPFIV-1(C)
MOVEM D,LAPFIV(C) ;INTERCHANGE KEYS
MOVE D,INIBSP(C)
EXCH D,INIBSP-1(C) ;INTERCHANGE RECORDS
MOVEM D,INIBSP(C)
INIBS2: SOJG C,INIBS1
JUMPN F,INIBS
MOVNI C,LLSYMS-1
MOVE AR2A,[441100,,LAP5P]
MOVE TT,INIBSP+LLSYMS-1(C)
IDPB TT,AR2A
AOJLE C,.-2
;;; INITIALIZE THE SEGMENT-LINK COUNTERS FOR ITS
IFN ITS,[
IRP A,,[FS,FX,FL,SY,SA,S2]B,,[IFS,IFX,IFL,SYM,SAR,IS2]
MOVEI T,L!B!SG
MOVEM T,A!SGLK
TERMIN
BG$ MOVEI T,LBNSG
BG$ MOVEM T,BNSGLK
IRPC Q,,[AB]
IFN NXX!Q!SG,[
MOVE T,IMSGLK
MOVE TT,[-NXX!Q!SG,,BXX!Q!SG←-SEGLOG]
DPB T,[SEGBYT,,GCST(TT)]
MOVEI T,(TT)
AOBJN TT,.-2
MOVEM T,IMSGLK
] ;END OF IFN NXX!Q!SG
TERMIN
MOVEI T,<<<ENDLISP+PAGSIZ-1>&PAGMSK>-BBPSSG>←-PAGLOG
MOVEI D,BBPSSG←-PAGLOG
ROT D,-4
ADDI D,(D)
ROT D,-1
TLC D,770000
ADD D,[450200,,PURTBL]
MOVEI TT,3
INIT5: TLNN D,730000
TLZ D,770000
IDPB TT,D
SOJG T,INIT5
MOVE T,[-<<<<ENDLISP+PAGSIZ-1>&PAGMSK>-BBPSSG>←-SEGLOG>,,ST+<BBPSSG←-SEGLOG>]
MOVE TT,[$XM,,QRANDOM]
MOVEM TT,(T)
AOBJN T,.-1
] ;END OF IFN ITS
IFE ITS,[
;;; INITIALIZE THE SEGMENT TABLES, AND LINK CONTERS FOR DEC-10
BZERSG==FIRSTLOC ;CROCK - BEWARE RELOCATION!
BSYSSG==HILOC
IN10ST: SETZ A, ;INIBD SETS NON-ZERO ON ERROR
MOVEI T,FIRSTLOC
MOVEI TT,FIRSTLOC ;DO NOT ATTEMPT TO PERFORM
SUBI TT,STDLO ; THIS ARITHMETIC AT ASSEMBLY
JSP F,INIBD ; TIME! WOULD USE WRONG
ASCIZ \LOW\ ; RELOCATION QUANTITIES
MOVEI T,HILOC
MOVEI TT,HILOC
SUBI TT,STDHI
MOVEM TT,MAXNXM
SOS MAXNXM
JSP F,INIBD
ASCIZ \HIGH\
SKIPE A
EXIT ;LOSE LOSE
MOVE T,[$NXM,,QRANDOM] ;INITIALIZE SEGMENT TABLES
MOVEM T,ST
MOVE T,[ST,,ST+1]
BLT T,ST+NSEGS-1
SETZM GCST
MOVE T,[GCST,,GCST+1]
BLT T,GCST+NSEGS-1
MOVEI AR1,BTBLKS ;AR1 ACTS AS BTB. [BIT-BLOCK COUNTER]
LSH AR1,5-SEGLOG
10ST ZER
10ST ST
10ST SAR,[SA,,QARRAY][GCBMRK+GCBSAR]SASGLK
10ST VC,[LS+VC,,QLIST][GCBMRK+GCBVC]
10ST IS2,,,S2SGLK
10ST SYM,[SY,,QSYMBOL][GCBMRK+GCBSYM]SYSGLK
10ST IFS,[LS+$FS,,QLIST][GCBMRK+GCBCDR+GCBCAR]FSSGLK,BITS
10ST IFX,[$FX,,QFIXNUM][GCBMRK]FXSGLK,BITS
10ST IFL,[$FL,,QFLONUM][GCBMRK]FLSGLK,BITS
BG$ 10ST BN,[BN,,QBIGNUM][GCBMRK+GCBCDR]BNSGLK,BITS
10ST BIT
10ST FXP,[$FXP,,QFIXNUM]
10ST FLP,[$FLP,,QFLONUM]
10ST P
10ST SP
10ST BPS
10ST SYS,[$XM+PUR,,QRANDOM]
10ST SY2
10ST PFS,[LS+$FS+PUR,,QLIST]
10ST PFX,[$FX+PUR,,QFIXNUM]
10ST PFL,[$FL+PUR,,QFLONUM]
IN10S5: HRRM AR1,BTBAOB
LSH AR1,SEGLOG-5
CAIN AR1,BFBTBS
JRST IN10S8
OUTSTR [ASCIZ \LOST WHILE INITIALIZING BIT BLOCKS
\]
EXIT 1,
IN10S8:
EXPUNGE BZERSG BSYSSG
] ;END OF IFE ITS
ININTR: MOVE A,[-KNOB+1-10,,OBTFS+1] ;SET UP OBLIST-LINKING CONSING AREAS
HRRZM A,-1(A)
AOBJN A,.-1
MOVEI F,OBTFS
MOVEM F,FFS
MOVE F,[-KNOB,,OBTL]
HRRZ A,(F)
PUSHJ P,INTERN
AOBJN F,.-2
IFN ITS,[
MOVE A,[SETO AR1,]
MOVEM A,PURIFY
MOVE A,BINIT9 ;CLOBBER INIT, SINCE ONLY NEED DO ONCE
MOVEM A,INIT
MOVE T,[DBGMSK] ;SET INTERRUPT MASKS
MOVEM T,INTMSK ; FOR DEBUGGING
Q$ MOVE T,[DBGMS2] ;(PURIFY WILL RESET
Q$ MOVEM T,INTMS2 ; TO STANDARD VALUES)
.BREAK 12,[..SSTA,,[LISPGO]] ;SET START ADDRESS
.CORE <ENDLISP+PAGSIZ-1>←-PAGLOG ;FLUSH PDL PAGES
.VALUE
BINIT9: .VALUE [ASCIZ \:≠INITIALIZED≠
\]
] ;END OF IFN ITS
IFN D10,[
MACROLOOP N2DIF,ZZD,*
MOVE C,[LVRNO]
SETZ A,
INIT2A: SETZ B,
LSHC B,6
JUMPE B,INIT2B
IMULI A,10.
ADDI A,-'0(B)
JRST INIT2A
INIT2B: LSH A,30 ;VERSION NUMBER STORED IN LOC 137 AS
MOVEM A,137 ;0XXX00,,0
MOVEI A,LISPGO
HRRM A,.JBSA"
MOVEM A,INIT
SA$ MOVEI FREEAC,1 ;SAIL SETUWP DOES NOT RETURN OLD VALUE IN AC AS DEC10
SETUWP FREEAC, ;RESTORE WRITE PROTECT STATUS
.VALUE
OUTSTR [ASCIZ \:$INITIALIZED$
\]
EXIT 1,
] ;END OF IFN D10
JRST LISPGO
;;; NOTE THAT THE SECOND $ IN THE MESSAGE HERE IS A REAL DOLLAR SIGN,
;;; WHILE THE OTHER TWO ARE ALTMODES; THUS DDT WON'T GET SCREWED!
IFN ITS,[
NOTINIT: .VALUE [ASCIZ \:≠LISP NOT INITIALIZED (USE INIT$G)≠
\]
] ;END OF IFN ITS
INIBSP: REPEAT LLSYMS, .RPCNT
IFN D10,[
;;; ROUTINE TO CHECK SEGMENT BOUNDARIES, AND IF LOSING,
;;; TELL LOSER HOW TO WIN WITH LINK-10.
INIBD: TRNN TT,SEGKSM
JRST 1(F) ;WIN
SETO A,
OUTSTR (F)
OUTSTR [ASCIZ \ SEGMENT ON BAD BOUNDARY. TELL LINK "/SET:.\]
OUTSTR (F)
OUTSTR [ASCIZ \.:\]
ANDI TT,SEGKSM
ADDI T,SEGSIZ
SUBI T,(TT)
HRLZ TT,T
MOVEI D,6
INIBD1: SETZ T,
LSHC T,3
ADDI T,"0
OUTCHR T
SOJG D,INIBD1
OUTSTR [ASCIZ \"
\]
JRST 1(F)
] ;END OF IFN D10
IFN ITS,[
IFE SEGLOG-11,[ ;VARIOUS PARAMETERS BUILT INTO UCODE
IFLE HNKLOG-5,[
;;; KL-10 INIT ROUTINE
KLINIT: MOVE T,[-NSEGS,,GCST]
KLINI1: MOVE TT,(T)
IFN HNKLOG, TLNN TT,GCBFOO+GCBHNK
.ELSE TLNN TT,GCBFOO
JRST KLINI2
MOVNI D,1
TLNE TT,GCBSYM
MOVEI D,0
TLNE TT,GCBVC
MOVEI D,1
TLNE TT,GCBSAR
MOVEI D,2
REPEAT HNKLOG,[
TLNE TT,GCBH1←-.RPCNT
MOVEI D,3+.RPCNT
] ;END OF REPEAT HNKLOG
SKIPGE D
.VALUE
IFN HNKLOG, TLZ TT,GCBFOO+GCBHNK
.ELSE TLZ TT,GCBFOO
TLO TT,200000
DPB D,[330300,,TT]
MOVEM TT,(T)
KLINI2: AOBJN T,KLINI1
MOVE T,[JRST KLGCM1]
MOVEM T,GCMRK0
MOVE T,[JRST KLGCSW]
MOVEM T,GCSWP
.VALUE [ASCIZ \:≠INITIALIZED FOR KL-10≠
\]
] ;END OF IFLE HNKLOG-5
] ;END OF IFE SEGLOG-11
] ;END OF IFN ITS
IFN D10,[
LOPDL==200
LOFXPDL==100
LOSPDL==40
LOFLPDL==10
ALBPS==7000
SA$ ALBPS==ALBPS+4000
] ;END OF IFN D10
SUBTTL HAIRY ALLHACK MACRO
DEFINE AMASC A,B
ASCIZ \
A!B \
TERMIN
DEFINE ALLHACK XLABEL,TP,NAME,STDALC,MINALC,EXTRA,WHERE,NWHERE
SKIPE ALLF
JRST XLABEL
PUSHJ P,ALLTYO
AMASC [TP! !NAME = ]\STDALC
MOVE AR1,[ASCII \NAME\]
PUSHJ P,ALLNUM
SKIPGE A
XLABEL: MOVEI A,STDALC
CAIGE A,MINALC
MOVEI A,MINALC
IFSN EXTRA,, ADDI A,EXTRA
HRRM A,WHERE
IFSN NWHERE,,[
MOVN B,A
HRRM B,NWHERE
]
PUSHJ P,ALLECO
TERMIN
SUBTTL ALLOC I/O ROUTINES
10% ALLJCL: BLOCK 80. ;BUFFER UP JOB COMMAND LINE IF THERE WAS ONE.
10% ALJCLP: -1 ;ALLOW ONLY ONE TRY FOR JCL (JOB COMMAND LINE)
ALLF: 0 ;NON-ZERO FOR STANDARD ALLOCATION
AINFIL: 0 ;NON-NIL MEANS LOAD .LISP. (INIT) FILE AFTER ALLOCING
ATYF: 0 ;TTYOFF FOR ALLOC
LICACR: 0 ;LAST INPUTED CHAR TO ALLOC WAS A CR -1 ==> YES
ALERR: STRT [SIXBIT \GC CALLED FROM ALLOC - LOSE, LISP IS DEAD!\]
.VALUE
;;; PUSHJ P,ALLTYO ;PRINT ASCIZ STRING FOR ALLOC
;;; ASCIZ \TEXT...\ ;NOTE: ASCIZ IS NOT IN [ ... ] !
ALLTYO: HRLI A,440700
HLLM A,(P)
ATYOI: ILDB A,(P)
JUMPE A,POPJ1
SKIPN ATYF
PUSHJ P,ALLTYC
JRST ATYOI
ALLECO: SKIPL AFILRD
SKIPE ATYF
POPJ P,
PUSH P,A
MOVE TT,A
HRROI R,TYO
PUSHJ P,PRINL4
POP P,A
POPJ P,
IFN SAIL,[
SAILP4: CAIN C,32 ;A TILDE?
JRST SAIP1
CAIN C,176 ;A }
JRST SAIP2
CAIE C,175 ;AN ALTMODE
JRST SAIP3
MOVEI C,33
JRST SAIP3
SAIP1: MOVEI C,176
JRST SAIP3
SAIP2: MOVEI C,175
SAIP3: TRZE C,600 ;CTRL/META/BOTH?
TRZ C,100 ;MAKE DEC STYLE
POPJ P,
] ;END OF IFN SAIL
ALLTYI:
IFN ITS,[
Q% .IOT TYIC,C
Q$ .IOT 0,C ;CHANNEL NUMBER FILLED IN
] ;END OF IFN ITS
IFN D10,[
INCHRW C
SA$ PUSHJ P,SAILP4
AOSG LICACR
JRST ATI1
ATI2: CAIN C,↑M
SETOM LICACR
] ;END OF IFN D10
10X WARN [TTY INPUT]
CAIN C,↑G
JRST ALLOC1
POPJ P,
IFN D10,[
ATI1: CAIN C,↑J ;FLUSH A SYSTEM-SUPPLIED LINE-FEED
INCHRW C ;FOLLOWING A CR
SA$ PUSHJ P,SAILP4
JRST ATI2
] ;END OF IFN D10
ALLTYC:
IFN ITS,[
CAIE A,↑J
ALOIOT:
Q% .IOT TYOC,A
Q$ .IOT 0,A ;QIO WILL CLOBBER CHANNEL HERE
] ;END OF IFN ITS
10$ OUTCHR A
10X WARN [TTY OUTPUT]
POPJ P,
ALLRUB: PUSHJ P,ALLTYO
ASCIZ \XX
\
ALLNUM: SKIPGE C,AFILRD ;GETS A NUMBER FOR SOME STORAGE AREA SIZE
JRST ALNM1
ALNM2: JUMPN C,ALNM27
SETO A,
POPJ P,
ALNM27: HLRZ A,(C) ;SEARCH THE READ IN LIST TO SEE
HRRZ C,(C) ;WHETHER LOSER HAS TRIED TO SPECIFY
JUMPE C,ALLNER ;ALLOCATION FOR THIS QUANTITY
SKOTT A,SY
JRST ALSYER
HLRZ A,(A)
HRRZ A,1(A)
HLRZ AR2A,(A)
HLRZ A,(C)
CAMN AR1,(AR2A)
JRST ALNM3
HRRZ C,(C)
JRST ALNM2
ALNM3:
SKOTT A,FX
JRST ALNMER
ALNMOK: MOVE A,(A)
POPJ P,
ALSYER: MOVEI D,[SIXBIT \NON-SYMBOL ALLOCATION AREA!\]
JRST ALCLZ1
ALNMER: MOVEI D,[SIXBIT \NON-FIXNUM ALLOCATION QUANTITY!\]
JRST ALCLZ1
ALLNER: MOVEI D,[SIXBIT \ODD LENGTH ALLOCATION COMMENT!\]
JRST ALCLZ1
ALNM1: MOVSI B,400000
MOVSI A,400000 ;GET VALUE FROM TTY
ALNM1A: PUSHJ P,ALLTYI
CAIE C,12
CAIN C,15
POPJ P,
CAIE C,33 ;ALT MODE SAYS "DONE ALLOCING"
JRST .+3
SETOM ALLF
POPJ P,
CAIN C,".
MOVE A,B
MOVE D,RCT0(C)
TLNE D,170000
POPJ P,
CAIL C,"0
CAILE C,"9
JRST ALLRUB
TLZ A,400000
TLZ B,400000
IMULI A,10
ADDI A,-"0(C)
IMULI B,10.
ADDI B,-"0(C)
JRST ALNM1A
IFN D10,[
DECDIG: SKIPE ATYF
POPJ P,
JUMPN T,DDIG1
OUTCHR [ASCII \0\]
DDIG1: JUMPE T,CPOPJ
IDIVI T,10
PUSH P,TT
PUSHJ P,DECDIG
POP P,TT
ADDI TT,"0
OUTCHR TT
POPJ P,
] ;END OF IFN D10
SUBTTL ALLOC (INIT) FILE ROUTINES
IFE QIO,[
ALOFIL:
IFN ITS,[ MOVEI C,(SIXBIT \DSK\) ;STANDARD FILE NAMES
MOVE A,[SIXBIT \.LISP.\] ; FOR INIT FILE
MOVE B,[SIXBIT \(INIT)\]
TDZA F,F ;F=0 => INIT REQUESTED VIA ↑Q OR ↑W
ALOFL1: MOVNI F,1 ;F<0 => INIT REQUESTED VIA JCL
ALOFL2: MOVEM A,UTIN+1
HRLI C,2
MOVEM C,UTIN
MOVEM B,UTIN+2
.OPEN UTIC,UTIN ;SO TRY TO OPEN INIT FILE
JRST ALFLER ;FILE NAMES ARE STILL IN A AND B
SKIPLE F ;F>0 => WERE TRYING (INIT) DIRECTORY
.SUSET [.SSNAM,,A] ; - WE WANT TO RESTORE OUR SNAME
] ;END OF IFN ITS
IFN D10,[
MOVE A,[SIXBIT \LISP\]
MOVSI B,(SIXBIT \INI\)
MOVSI C,(SIXBIT \DSK\)
ALOFL1: MOVEI C+2,UTIHED
MOVE C+1,C
MOVEI C,0
OPEN UTIC,C ;OPEN THE CHANNEL
JRST ALFLER
SETZB C,AR1 ;USE NO PPN
SA$ DSKPPN=047000,,400071
SA$ DSKPPN AR1,
LOOKUP UTIC,A
JRST ALFLER ;FILE NAMES ARE STILL IN A AND B
MOVEI T,UTIB-3
EXCH T,.JBFF"
INBUF UTIC,1
EXCH T,.JBFF"
] ;END OF IFN D10
LOCKI ;UREAD2 WILL UNLOCKI
MOVEM A,URFN1
MOVEM B,URFN2
SETOM ALGCF ;TELLS UREAD NOT TO TRY TO CONS
PUSHJ P,UREAD2 ;DOES AN UNLOCKI
SETZM ALGCF
MOVEI A,TRUTH
MOVEM A,TAPRED
SETOM AFILRD
POPJ P,
] ;END OF IFE QIO
IFN QIO,[
ALOFIL: MOVSI C,(SIXBIT \DSK\)
MOVE A,[SIXBIT \.LISP.\]
MOVE B,[SIXBIT \(INIT)\]
.SUSET [.RSNAM,,F]
ALOFL1: .CALL ALOFL6 ;DOES INIT FILE EXIST?
JRST ALOFL2
MOVEM C,INIIF2+F.DEV ;YES, SAVE FILE NAMES
MOVEM F,INIIF2+F.SNM
MOVEM A,INIIF2+F.FN1
MOVEM B,INIIF2+F.FN2
JRST ALOFL4
ALOFL2: CAMN B,[SIXBIT \(INIT)\] ;IF SECOND FILE NAME IS (INIT),
.CALL ALOFL7 ; TRY THE (INIT) DIRECTORY
JRST ALFLER ;OTHERWISE LOSE
MOVEM C,INIIF2+F.DEV ;SAVE FILE NAMES
MOVEM B,INIIF2+F.SNM
MOVEM F,INIIF2+F.FN1
MOVEM A,INIIF2+F.FN2
ALOFL4: .CLOSE TMPC,
PUSH P,[ALOFL5]
PUSH P,[INIIFA]
MOVNI T,1
JRST $OPEN ;OPEN INIT FILE ARRAY
ALOFL5: MOVEM A,VINFILE
MOVEI A,TRUTH
MOVEM A,TAPRED
SETOM AFILRD
POPJ P,
ALOFL6: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,2 ;MODE (ASCII BLOCK INPUT)
1000,,TMPC ;CHANNEL #
,,C ;DEVICE
,,A ;FILE NAME 1
,,B ;FILE NAME 2
400000,,F ;SNAME
ALOFL7: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,2 ;MODE (ASCII BLOCK INPUT)
1000,,TMPC ;CHANNEL #
,,C ;DEVICE
,,F ;FILE NAME 1
,,A ;FILE NAME 2
400000,,B ;SNAME
] ;END OF IFN QIO
ALLFIL: PUSHJ P,ALOFIL ;OPEN INIT FILE
ALLFL1:
Q% SETOM RRDF
Q$ SETZM BFPRDP
PUSHJ P,READ ;READ IN ALLOCATIONS "COMMENT"
SETZM ALGCF
HLRZ B,(A)
CAIE B,Q$COMMENT
JRST ALCLUZ
ALLFL2: HRRZ A,(A)
MOVEM A,AFILRD ;SAVE IT (ACTUALLY, ITS CDR)
JRST ALLOCC
ALCLUZ: MOVEI D,[SIXBIT \ALLOC COMMENT MISSING IN INIT FILE!\]
ALCLZ1:
Q% MOVE A,URFN1
Q% MOVE B,URFN2
IFN QIO,[
HRRZ A,VINFILE
SETZM VINFILE
PUSH FXP,D
PUSHJ P,$CLOSE
POP FXP,D
MOVE A,INIIF2+F.FN1
MOVE B,INIIF2+F.FN2
MOVE F,INIIF2+F.SNM
] ;END OF IFN QIO
JRST ALCERR
IFN ITS,[
ALLTTS: SETZ ;TTYSET FOR ALLOC - NO INTERRUPT CHARS!
SIXBIT \TTYSET\ ;SET TTY VARIABLES
Q% 1000,,TYIC ;CHANNEL #
Q$ ,,TTYIF2+F.CHAN ;CHANNEL #
,,[STTYA1] ;TTYST1
Q% ,,[STTYA2] ;TTYST2
Q$ 400000,,[STTYA2]
Q% 400000,,STTYSS ;TTYSTS
] ;END OF IFN ITS
ALHELP: PUSHJ P,ALLTYO
ASCIZ \
N = DON'T ALLOCATE (I.E. USE DEFAULTS)
Y = ALLOC FROM TTY
↑Q = READ INIT FILE AND ALLOC FROM IT
↑S = ALLOC FROM TTY, THEN READ INIT FILE
↑W = SAME AS ↑Q, BUT NO ECHO ON TTY
ALTMODE, TYPED AT ANY TIME, TERMINATES ALLOCATION PHASE,
TAKING REMAINING PARAMETERS AS DEFAULTS
↑G RESTARTS ALLOC
LINES PROMPTED BY A "#" CANNOT BE RE-ALLOCATED AFTER RUNNING
THOSE PROMPTED BY A " " CAN BE RE-ALLOCATED AT ANY TIME WITH
THE LISP FUNCTION "ALLOC"
TERMINATE CURRENT ENTRY (USUALLY A NUMBER) WITH CR OR SPACE
CR OR SPACE TYPED WITHOUT PRECEEDING NUMBER TAKES DEFAULT FOR
THAT ENTRY
RUBOUT RESTARTS CURRENT ENTRY
NUMBERS ARE TYPED IN BASE EIGHT, UNLESS SUFFIXED BY .
IN WHICH CASE BASE TEN IS USED
ALL ENTRIES ARE IN UNITS OF PDP-10 WORDS,
EXCEPT CORE, WHICH IS IN \
PUSHJ P,ALLTYO
IFN ITS,[ASCIZ \1K BLOCKS
\]
IFN D10,[ASCIZ \512.-WORD BLOCKS
\]
JRST ALLOC1
ALFLER:
IFE D10\QIO,[
JUMPG F,ALFLE3 ;LOSE IF WE ALREADY TRIED (INIT);
CAME B,[SIXBIT \(INIT)\]
JRST ALFLE3 ;LOSE IF SECOND NAME NOT (INIT)
MOVE B,A ;ELSE PERMUTE FOO;BAR (INIT) TO BE
.SUSET [.RSNAM,,A] ; (INIT);FOO BAR INSTEAD
.SUSET [.SSNAM,,[SIXBIT \(INIT)\]]
MOVEI F,1 ;WE CAN ONLY TRY THIS HACK ONCE
JRST ALOFL2
ALFLE3: JUMPL F,ALFLE4 ;IF WE WERE LOOKING AT THE (INIT)
.SUSET [.SSNAM,,A] ; DIRECTORY, MUST RESTORE THINGS
MOVE A,B
MOVE B,[SIXBIT \(INIT)\]
ALFLE4:
] ;END OF IFE D10\QIO
MOVEI D,[SIXBIT \ INIT FILE NOT FOUND!\]
ALCERR: SETZM TAPRED
SETZM TTYOFF
SETZM TAPWRT
STRT [SIXBIT \ !\]
IFN ITS,[
Q% .SUSET [.RSNAM,,AR1]
Q$ MOVE AR1,F
MOVEI T,";
PUSHJ P,ALFL6
] ;END OF IFN ITS
MOVE AR1,A
10% MOVEI T,40
10$ MOVEI T,".
PUSHJ P,ALFL6
MOVE AR1,B
MOVEI T,40
PUSHJ P,ALFL6
STRT (D)
SA$ CLRBFI ;CLEAR INPUT BUFFER FOR SAIL
JRST ALLOC
ALFL6: SETZ AR2A,
MOVE TT,[440600,,AR1]
ALFL6A: ILDB R,TT
JUMPE R,ALFL6B
ADDI R,40
10% Q% .IOT TYOC,R
10% Q$ ALFL6C: .IOT 0,R ;CHANNEL # FILLED IN
10$ OUTCHR R
10X WARN [TTY OUTPUT]
JRST ALFL6A
ALFL6B:
10% Q% .IOT TYOC,T
10% Q$ .IOT 0,T ;CHANNEL # FILLED IN
10$ OUTCHR T
10X WARN [TTY OUTPUT]
POPJ P,
SUBTTL MAIN ALLOC INTERACTION CODE
ALLOC:
IFN D10,[
SETZM LICACR
MOVEM 0,SGANAM ;SAVE MAGIC STUFF FOR GETHGH
MOVEM 11,SGADEV
MOVEM 7,SGAPPN
MOVE 0,[112,,11]
SA% GETTAB
SETZB 0,SGANAM
LDB 0,[061400,,0]
CAIE 0,1 ;REAL TOPS-10 SYSTEM, RATHER THAN SIMULATOR
SETZB 0,SGANAM ;ON VARIOUS SIMULATIONS, DONT KILL HISEG
] ;END OF IFN D10
MOVE A,[RCT0,,RCT]
BLT A,RCT+LRCT-1
IFN ITS,[
MOVE TT,[4400,,400000+<<PDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<SPDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FXPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FLPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
] ;END OF IFN ITS
MOVE P,C2
MOVE SP,SC2
MOVE FXP,FXC2
MOVE FLP,FLC2
MOVE A,[-LFSALC+1,,FSALC+1] ;SET UP ALLOC CONSING AREAS
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-LFWSALC+1+NIFWAL,,FWSALC+1+NIFWAL]
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-LSYALC+1,,SYALC+1]
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-NIS2SG*SEGSIZ/2+1,,SY2ALC+2]
HRRZM A,-2(A)
ADDI A,1
AOBJN A,.-2
MOVE A,[-INFVCS+1,,BFVCS+1]
HRRZM A,-1(A)
AOBJN A,.-1
MOVEI A,FSALC ;SET UP PHONY FREELISTS
MOVEM A,FFS
MOVEI A,FWSALC+NIFWAL
MOVEM A,FFX
MOVEI A,SYALC
MOVEM A,FFY
SETOM ALGCF ;ERROR OUT ON GC (UNTIL FURTHER NOTICE)
SETZB NIL,ATYF
SETOM AFILRD
IFN ITS,[
IFE QIO,[
MOVSI TT,(ASCII \@\)
MOVEM TT,UFN1
MOVEM TT,UFN2
MOVE TT,[STTYW1]
MOVEM TT,STTYS1
MOVE TT,[STTYW2]
MOVEM TT,STTYS2
PUSHJ P,TTYOPN
] ;END OF IFE QIO
IFN QIO,[
.SUSET [.RSNAM,,T]
IRP FIL,,[TTYIF2,TTYOF2]
MOVEM T,FIL+F.SNM
TERMIN
PUSH FXP,[SIXBIT \DSK\]
PUSH FXP,T
REPEAT 2, PUSH FXP,[SIXBIT \@\]
PUSHJ P,6BTNML
MOVEM A,VDEFAULTF
PUSHJ P,OPNTTY ;OPEN TTY INPUT AND OUTPUT
.VALUE ;MUST HAVE TTY TO DO ALLOC
MOVE T,TTYOF2+F.CHAN ;INITIALIZE CHANNEL NUMBER FOR
DPB T,[270400,,ALOIOT] ; ALLOC'S OUTPUT .IOT TO TTY
DPB T,[270400,,ALFL6B]
DPB T,[270400,,ALFL6C]
MOVE T,TTYIF2+F.CHAN ;NOW DO THE SAME FOR
DPB T,[270400,,ALLTYI] ; THE INPUT .IOT
] ;END OF IFN QIO
AOSE ALJCLP
JRST ALJ3
.SUSET [.ROPTION,,TT]
TLNE TT,20000 ;NOT DDT ABOVE LISP
TLZN TT,40000 ;IF THERE IS JOB COMMAND LINE, TURN IT OFF AFTER READING
JRST ALJ3 ;NO JOB COMMAND LINE
.BREAK 12,[..RJCL,,ALLJCL]
SETZB A,C
SETZB D,F
MOVE B,[SIXBIT \(INIT)\]
MOVE AR1,[440700,,ALLJCL]
ALJ1: MOVE AR2A,[440600,,T]
SETZ T,
ALJ1A: ILDB TT,AR1
JUMPE TT,ALJ2
CAIGE TT,"!
JRST ALJ1B
CAIE TT,":
JRST ALJ1A1
Q% HLRZ C,T
Q$ MOVE C,T
AOJA D,ALJ1
ALJ1A1: CAIE TT,";
JRST ALJ1A2
MOVE F,T
AOJA D,ALJ1
ALJ1A2: CAIL TT,"a ;LOWER-CASE
CAILE TT,"z
ADDI TT,40
ANDI TT,77
TLNE AR2A,770000
IDPB TT,AR2A
JRST ALJ1A
ALJ1B: JUMPE T,ALJ1B2
JUMPE A,ALJ1B1
MOVEM T,B
JRST ALJ1B2
ALJ1B1: MOVEM T,A
ALJ1B2: CAIN TT,33 ;ALTMODE MEANS INIT FILE CAN GET JCL
JRST ALJ2Q
CAIE TT,↑M
JRST ALJ1
ALJ2: .SUSET [.ROPTION,,TT]
TLZ TT,OPTCMD ;TURN OFF JCL
.SUSET [.SOPTION,,TT]
ALJ2Q: SKIPN C
Q% MOVEI C,(SIXBIT \DSK\)
Q$ MOVSI C,(SIXBIT \DSK\)
JUMPN A,ALJ2A
JUMPE D,ALJ3
MOVE A,[SIXBIT \.LISP.\]
ALJ2A: SKIPE F
.SUSET [.SSNAM,,F]
Q$ SKIPN F
Q$ .SUSET [.RSNAM,,F]
SETOM ATYF
PUSHJ P,ALOFL1
JRST ALLFL1
ALJ3: .CALL ALLTTS
.VALUE
] ;END OF IFN ITS
IFN D10,[
JSP F,JCLSET
SKIPN SJCLBUF
JRST ALJ3
SETZ D, ;D TELLS WHETHER OR NOT A . WAS SEEN
SETZB A,C
MOVSI B,(SIXBIT \INI\)
MOVE AR1,[440700,,SJCLBUF+1]
ALJ1: MOVE AR2A,[440600,,T]
SETZ T,
ALJ1A: ILDB TT,AR1
JUMPE TT,ALJ2
CAIGE TT,"!
JRST ALJ1B
CAIE TT,":
JRST ALJ1A1
MOVE C,T
JRST ALJ1
ALJ1A1: CAIE TT,".
JRST ALJ1A2
MOVE A,T
SETZ B,
AOJA D,ALJ1
ALJ1A2: CAIL TT,"a ;LOWER CASE
CAILE TT,"z
ADDI TT,40
ANDI TT,77
TLNE AR2A,770000
IDPB TT,AR2A
JRST ALJ1A
ALJ1B: JUMPE T,ALJ1B2
SKIPN D
SKIPA A,T
HLLZ B,T
ALJ1B2: CAIN TT,33 ;ALT-MODE SAYS DONT FLUSH JCL
JRST ALJ2Q
CAIN TT,↑M
JRST ALJ1
ALJ2: SETZM SJCLBUF
ALJ2Q: SKIPN C
MOVSI C,(SIXBIT \DSK\)
SETOM ATYF
PUSHJ P,ALOFL1
JRST ALLFL1
ALJ3:
] ;END OF IFN D10
PUSHJ P,ALLTYO
ASCIZ \
LISP \
MOVE B,[LVRNO]
ALLOCB: SETZ A,
LSHC A,6
JUMPE A,ALLOCA
ADDI A,40
PUSHJ P,ALLTYC
JRST ALLOCB
ALLOCA:
IFN D10,[
PUSHJ P,SIXJBN
MOVE TT,D10NAM ;MOVE IN ###LSP FOR FILENAME
MOVEM TT,UFN1
MOVSI TT,(SIXBIT /TMP/)
MOVEM TT,UFN2
] ;END OF IFN D10
PUSHJ P,ALLTYO
IFN ITS,[
Q% ASCIZ \ WITH LOSING OLD I/O\
Q$ ASCIZ \ WITH WINNING NEW I/O\
]
IFE ITS,[
Q% ASCIZ \ WITH OLD I/O\
Q$ ASCIZ \WITH NEW I/O\
]
ALLOC1: PUSHJ P,ALLTYO
ASCIZ \
ALLOC? \
PUSHJ P,ALLTYI
SETZM ALLF
CAIN C,↑W
SETOM ATYF
CAIE C,↑W
CAIN C,↑Q
JRST ALLFIL
CAIE C,33 ;ALTMODE
CAIN C,40 ;SPACE
SETOM ALLF
CAIE C,↑S
JRST .+3
SETOM AINFIL
JRST ALLOCC
CAIE C,"n ;LOWER CASE
CAIN C,"N
SETOM ALLF
SKIPE ALLF
JRST ALLOCC
CAIE C,"Y
CAIN C,"y ;LOWER CASE
JRST ALLOCC
CAIN C,"?
JRST ALHELP
CAIE C,"H
CAIN C,"h ;LOWER CASE
JRST ALHELP
SA$ BEEP=047000,,400111
SA$ SETOM A
SA$ BEEP A,
SA% MOVEI A,↑G ;RANDOM ILLEGAL CHARACTER TO ALLOC
SA% PUSHJ P,ALLTYC
Q% 10% .RESET TYIC, ;RESET ANY TYPE-AHEAD
Q% 10$ CLRBFI
Q$ 10% .CALL CKI2I
Q$ 10% .VALUE
JRST ALLOC1
IFN ITS,[ ALCORX==<BBPSSG-SEGSIZ*<NIFSSG+NIFXSG+NIFLSG+NXXZSG>>/PAGSIZ
ALCORE==ALCORX+<MAXFFS+MAXFFX+MAXFFL+MAXFFB+MAXFFY+MAXFFA+PAGSIZ-1>/PAGSIZ
]
.ELSE [ ALCORX==<BBPSSG-FIRSTLOC+STDLO-SEGSIZ*<NIFSSG+NIFXSG+NIFLSG+NXXZSG>>/PAGSIZ
ALCORE==ALCORX+4
]
ALLOCC:
10$ ALLHACK ASBPS,#,BPS,ALBPS,ENDLISP-BBPSSG,,BPSH
ALLHACK ASRPDL,#,REGPDL,ALPDL,200,100,OC2
ALLHACK ASSPDL,#,SPECPDL,ALSPDL,200,100,OSC2
ALLHACK ASFXP,#,FXPDL,ALFXP,200,LSWS+12,OFXC2
ALLHACK ASFLP,#,FLPDL,ALFLP,10,10,OFLC2
10$ ALLHACK ASDDT,#,DDTSYMS,100,20,,SYMLO
ALLHACK ASLIST,,LIST,MAXFFS,200,,XFFS
ALLHACK ASSYM,,SYMBOL,MAXFFY,200,,XFFY
ALLHACK ASFIX,,FIXNUM,MAXFFX,200,,XFFX
ALLHACK ASFLO,,FLONUM,MAXFFL,200,,XFFL
IFN BIGNUM, ALLHACK ASBIG,,BIGNUM,MAXFFB,100,,XFFB
ALLHACK ASARY,,ARRAY,MAXFFA,100,,XFFA
PUSHJ P,ALLTYO
ASCIZ \
\
SUBTTL RUNTIME STORAGE ALLOCATION
MOVEI TT,ALCORX*PAGSIZ
IRP Q,,[S,X,L,B,Y,A]Z,,[FS,FX,FL,BN,SY,SA]N,,[NIFSSG+2,NIFXSG+2
NIFLSG+1,NBNSG,NSYMSG+1,NSARSG]FLG,,[1,1,1,BIGNUM,1,1]
IFN FLG,[
MOVEI T,<N>*SEGSIZ
CAML T,XFF!Q
MOVEM T,XFF!Q
MOVE T,XFF!Q
CAMGE T,G!Z!SIZ
MOVEM T,G!Z!SIZ
ADD TT,T
LSH T,-4 ;HACK
CAIGE T,SEGSIZ
MOVEI T,SEGSIZ
CAILE T,4000
MOVEI T,4000
CAML T,G!Z!SIZ
SUBM T,G!Z!SIZ
] ;END OF IFN FLG
TERMIN
MOVEI D,ALCORE
SUB D,TT
JUMPLE D,ALLCZX
IRP Q,,[S,X,L,Y]%%%,,[70.,15.,3.,12.]
MOVEI T,(D)
IMULI T,%%%
IDIVI T,100.
ADDM T,XFF!Q
TERMIN
ALLCZX==.
;FALLS THROUGH
;FALLS IN
IFE D10,[
ALLCPD: SETZ F,
MOVEI R,MEMORY-NSCRSG*SEGSIZ
IRP Q,,[SC2,C2,FLC2,FXC2]Y,,[1,0,0,0]W,,[SPDL,PDL,FLP,FXP]
MOVEI T,(R)
SUBI T,MIN!W
EXCH T,O!Q
CAIGE T,MIN!W
MOVEI T,MIN!W
MOVEM T,X!W
ADDI T,PAGSIZ-1+MIN!W
ANDI T,PAGMSK
MOVEI TT,(T)
LSH TT,-PAGLOG
SUBI F,(TT)
SUBI R,(T)
MOVEI D,PAGSIZ-20
CAML D,X!W
MOVE D,X!W
MOVNS D
HRLS D
HRRI D,(R)
IFN <Y>, ADD D,R70+Y
MOVEM D,Q
MOVEI D,(R)
ADD D,X!W
ANDI D,777760 ;KEEP AWAY FROM PAGE BOUNDARIES!
TRNN D,PAGKSM
SUBI D,20
MOVEM D,X!W
MOVEM D,Z!W
TERMIN
HRLM F,PDLFL1
IMULI F,SGS%PG
HRLM F,PDLFL2
MOVEI F,(R)
LSH F,-PAGLOG
HRRM F,PDLFL1
MOVEI F,(R)
LSH F,-SEGLOG
HRRM F,PDLFL2
SUBI R,1
MOVEM R,HINXM
HRRZ A,SC2
MOVEM A,ZSC2
HRRZ A,C2
ADDI A,1
MOVEM A,NPDLH
HRRZ A,FXC2
ADDI A,1
MOVEM A,NPDLL
JRST ALLDONE
] ;END OF IFE D10
;FALLS IN
IFN D10,[
ALLCPD: MOVEI A,BFXPSG
MOVEM A,NPDLL
MOVEI B,LOFXPDL ;SET UP FXP
ADD B,OFXC2
ADDI B,SEGSIZ-1
ANDI B,SEGMSK
MOVNI C,-LOFXPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,FXC2
ADDI C,-LOFXPDL(B)
HRLI C,-LOFXPDL
MOVEM C,OFXC2
MOVE C,[$FXP,,QFIXNUM]
JSP T,ALSGHK
MOVEI B,LOFLPDL ;SET UP FLP
ADD B,OFLC2
ADDI B,SEGSIZ-1
ANDI B,SEGMSK
MOVNI C,-LOFLPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,FLC2
ADDI C,-LOFLPDL(B)
HRLI C,-LOFLPDL
MOVEM C,OFLC2
MOVE C,[$FLP,,QFLONUM]
JSP T,ALSGHK
MOVEM A,NPDLH
MOVEI B,LOPDL+LOSPDL+1 ;SET UP P AND SP
ADD B,OC2
ADD B,OSC2
MOVEI AR1,SEGSIZ-1(B)
ANDI AR1,SEGMSK
MOVEI AR2A,(AR1)
MOVEI F,(A)
SUBI AR1,(B)
LSH AR1,-1 ;SPLIT SEGMENT REMAINDER
MOVE B,OC2
ADDI B,LOPDL(AR1)
MOVNI C,-LOPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,C2
ADDI C,-LOPDL(B)
HRLI C,-LOPDL
MOVEM C,OC2
ADDI A,(B)
MOVE B,OSC2
ADDI B,LOSPDL+1(AR1)
MOVNI C,-LOSPDL-1(B)
MOVSI C,(C)
HRRI C,(A) .SEE UBD ;SP NEEDS FUNNY SLOT
MOVEM C,SC2
HRRZM C,ZSC2
ADDI C,-LOSPDL-1(B)
HRLI C,-LOSPDL
MOVEM C,OSC2
MOVEI A,(F)
MOVEI B,(AR2A)
MOVE C,[$XM,,QRANDOM]
JSP T,ALSGHK
MOVEM A,BPSL
MOVEM A,VBP1
MOVE C,A
ADDB C,BPSH ;FIRST ESTIMATE OF BPSH
HRRZ B,.JBSYM
JUMPE B,ALCPD1
SUB B,SYMLO
CAIG C,(B)
MOVE C,B
MOVEM C,BPSH ;SECOND ESTIMATE OF BPSH
ADD C,SYMLO
HLRE B,.JBSYM"
HRRO D,.JBSYM
SUB D,B
SUBI D,1 ;TO BE A PDL PTR IN THE SYMMOV
SUB C,B
ALCPD1: IORI C,SEGKSM ;HIGHEST ADDR FOR AUGMENTED SYMTAB
MOVEI B,1(C)
CAMG C,.JBFF
JRST .+3
CORE C,
JRST ALQX2
HRRM B,.JBFF"
MOVEI F,-1(B)
SUB B,BPSL ;TOTAL NUMBER WDS OCCUPIED BY RANDOM BPS AND SYMTAB
SUBI F,(D) ;TOTAL DISTANCE THAT SYMTAB MOVES
HLRE R,.JBSYM
JUMPE R,ALQX1
JUMPE F,ALQX1
MOVE TT,[SYMMOV,,SYMMV1]
BLT TT,LPROGS
HRRI SYMMV1,(F)
JRST SYMMV1
SYMMV6: ADDI SYMMV1,1(D)
HRRM SYMMV1,.JBSYM"
SUB SYMMV1,SYMLO
SUBI SYMMV1,1
HRRZM SYMMV1,BPSH ;IF THERE WAS A SYMTAB, NOW WE KNOW WHERE BPSH IS
IFE SAIL,[
MOVE F,[112,,11]
GETTAB F,
SETZ F,
LDB F,[061400,,A]
CAIN F,3
HRRM SYMMV1,@770001 ;TENEX SIMULATOR FOR TOPS-10
] ;END OF IFE SAIL
ALQX1: MOVE C,SYMLO
ASH C,-1
MOVEM SYMLO ;CONVERT FROM # OF WORDS TO # OF ENTRIES
HRRZ C,BPSH
MOVEM C,VBPE1 ;INITIAL SETTING OF BPEND
MOVE C,[$XM,,QRANDOM]
JSP T,ALSGHK
MOVEI C,-1(A)
MOVEM C,HIXM
MOVEI B,HILOC
ANDI B,SEGMSK
SUBI B,(A)
MOVE C,[$NXM,,QRANDOM]
JSP T,ALSGHK
JRST ALLDONE
ALSGHK: MOVEI TT,(A)
MOVNI D,(B)
LSH TT,-SEGLOG
ASH D,-SEGLOG
HRLI TT,(D)
MOVEM C,ST(TT)
AOBJN TT,.-1
ADDI A,(B)
JRST (T)
ALQX2: PUSHJ P,ALLTYO
ASCIZ \
CAN'T GET ENOUGH CORE!\
JRST ALLOC1
] ;END OF IFN D10
ALLDONE: MOVEI A,LISP
HRRM A,LISPSW
10$ MOVEI A,GOINIT
10$ HRRM A,.JBSA"
SETZM ALGCF ;GC IS OKAY NOW
JRST LISP
IFN D10,[
SYMMOV: ;MOVE MOBY JOB SYMBOL TABLE UPWARDS
OFFSET C-.
SYMMV1: POP D,.(D) ;C
AOJL R,SYMMV1 ;AR1
JRST SYMMV6 ;AR2A
LPROGS==.-1
OFFSET 0
.HKILL SYMMV1
] ;END OF IFN D10
IFN QIO,[
;;; INITIAL ARRAYS IN SYSTEM GO HERE.
.SEE GCMKL
.SEE IGCMKL
.SEE VBPE1
SUBTTL INITIAL INIT FILE ARRAY FOR .LISP. (INIT) FILE
-F.GC,,INIIF2 ;GC AOBJN POINTER
INIIF1: JSP TT,1DIMS
INIIFA ;POINTER TO SAR
0 ;CAN'T ACCESS
INIIF2:
OFFSET -.
FI.EOF:: NIL ;EOF FUNCTION
FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS
FI.BBF:: NIL ;BUFFERED BACK FORMS
0 ;UNUSED
NIL ;UNUSED
BLOCK 3
F.MODE:: 0 ;MODE (BLOCK ASCII DSK INPUT)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
F.DEV:: SIXBIT \DSK\ ;DEVICE
F.SNM:: 0 ;SNAME/PPN (FILLED IN)
F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
F.FN2:: SIXBIT \(INIT)\ ;FILE NAME 2
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
F.FPOS:: -1 ;FILEPOS
0 ;UNUSED
0 ;UNUSED
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
0 ;UNUSED
0 ;UNUSED
BLOCK 6
FB.BFL:: ADIB.BS ;BUFFER LENGTH
AB.CNT:: 0 ;CHARACTER COUNT
AB.BP:: 0 ;BYTE POINTER
FB.IOT:: 0 ;IOT POINTER
BLOCK 4
FB.BUF:: BLOCK ADIB.BS ;BUFFER
OFFSET 0
LINIFA==.-INIIF1+1 ;TOTAL NUMBER OF WORDS
EINIFA==. ;END OF ARRAY
IFN .-INIIF2-ADIB.SZ, WARN [WRONG LENGTH INIT FILE ARRAY]
] ;END OF IFN QIO
;;@ END OF ALLOC 92
PRINTX \
\ ;JUST TO MAKE LSPTTY LOOK NICER
EXPUNGE ZZ ZY ZX ZZX ZZY ZZZ ZZW
10$ IF2, BSYSSG==400000 ;ANTI-RELOCATION CROCK
IF2, MACROLOOP NBITMACS,BTMC,* ;FOR BIT TYPEOUT MODE
CONSTANTS ;FOR ALLOC
ENDLISP==. ;END OF LISP, BY GEORGE!
VARIABLES ;NO ONE SHOULD USE VARIABLES!
IFN .-ENDLISP, WARN [OKAY, WHO'S THE WISE GUY USING VARIABLES?]
END INIT